diff options
| author | Richard Kenner <kenner@vlsi1.ultra.nyu.edu> | 2001-10-02 14:30:19 +0000 |
|---|---|---|
| committer | Richard Kenner <kenner@vlsi1.ultra.nyu.edu> | 2001-10-02 14:30:19 +0000 |
| commit | 8e0659c6ffc9c951302bbadae8697e84aefd13e4 (patch) | |
| tree | 86d33ed164722c539e5c03eb27ae96b8b7667e75 | |
| parent | c55b3789aeaee2f2f15bb4fafddaca76f4fe5b1e (diff) | |
New Language: Ada
git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@45957 138bc75d-0d04-0410-961f-82ee72b054a4
366 files changed, 55727 insertions, 0 deletions
diff --git a/gcc/ada/s-addima.adb b/gcc/ada/s-addima.adb new file mode 100644 index 00000000000..dcfc5053307 --- /dev/null +++ b/gcc/ada/s-addima.adb @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ I M A G E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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 Unchecked_Conversion; + +function System.Address_Image (A : Address) return String is + + Result : String (1 .. 2 * Address'Size / Storage_Unit); + + type Byte is mod 2 ** 8; + for Byte'Size use 8; + + Hexdigs : + constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF"; + + type Bytes is array (1 .. Address'Size / Storage_Unit) of Byte; + for Bytes'Size use Address'Size; + + function To_Bytes is new Unchecked_Conversion (Address, Bytes); + + Byte_Sequence : constant Bytes := To_Bytes (A); + + LE : constant := Standard'Default_Bit_Order; + BE : constant := 1 - LE; + -- Set to 1/0 for True/False for Little-Endian/Big-Endian + + Start : constant Natural := BE * (1) + LE * (Bytes'Length); + Incr : constant Integer := BE * (1) + LE * (-1); + -- Start and increment for accessing characters of address string + + Ptr : Natural; + -- Scan address string + +begin + Ptr := Start; + for N in Bytes'Range loop + Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16); + Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16); + Ptr := Ptr + Incr; + end loop; + + return Result; + +end System.Address_Image; diff --git a/gcc/ada/s-addima.ads b/gcc/ada/s-addima.ads new file mode 100644 index 00000000000..34c2ef7769a --- /dev/null +++ b/gcc/ada/s-addima.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ I M A G E -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNAT specific addition which provides a useful debugging +-- procedure that gives an (implementation dependent) string which +-- identifies an address. + +function System.Address_Image (A : Address) return String; +pragma Pure (System.Address_Image); +-- Returns string (hexadecimal digits with upper case letters) representing +-- the address (string is 8/16 bytes for 32/64-bit machines). diff --git a/gcc/ada/s-arit64.adb b/gcc/ada/s-arit64.adb new file mode 100644 index 00000000000..f4c8532ee3f --- /dev/null +++ b/gcc/ada/s-arit64.adb @@ -0,0 +1,719 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 6 4 -- +-- -- +-- 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 GNAT.Exceptions; use GNAT.Exceptions; + +with Interfaces; use Interfaces; +with Unchecked_Conversion; + +package body System.Arith_64 is + + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + + subtype Uns64 is Unsigned_64; + function To_Uns is new Unchecked_Conversion (Int64, Uns64); + function To_Int is new Unchecked_Conversion (Uns64, Int64); + + subtype Uns32 is Unsigned_32; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "+" (A, B : Uns32) return Uns64; + function "+" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("+"); + -- Length doubling additions + + function "-" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("-"); + -- Length doubling subtraction + + function "*" (A, B : Uns32) return Uns64; + function "*" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("*"); + -- Length doubling multiplications + + function "/" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("/"); + -- Length doubling division + + function "rem" (A : Uns64; B : Uns32) return Uns64; + pragma Inline ("rem"); + -- Length doubling remainder + + function "&" (Hi, Lo : Uns32) return Uns64; + pragma Inline ("&"); + -- Concatenate hi, lo values to form 64-bit result + + function Lo (A : Uns64) return Uns32; + pragma Inline (Lo); + -- Low order half of 64-bit value + + function Hi (A : Uns64) return Uns32; + pragma Inline (Hi); + -- High order half of 64-bit value + + function To_Neg_Int (A : Uns64) return Int64; + -- Convert to negative integer equivalent. If the input is in the range + -- 0 .. 2 ** 63, then the corresponding negative signed integer (obtained + -- by negating the given value) is returned, otherwise constraint error + -- is raised. + + function To_Pos_Int (A : Uns64) return Int64; + -- Convert to positive integer equivalent. If the input is in the range + -- 0 .. 2 ** 63-1, then the corresponding non-negative signed integer is + -- returned, otherwise constraint error is raised. + + procedure Raise_Error; + pragma No_Return (Raise_Error); + -- Raise constraint error with appropriate message + + --------- + -- "&" -- + --------- + + function "&" (Hi, Lo : Uns32) return Uns64 is + begin + return Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" (A, B : Uns32) return Uns64 is + begin + return Uns64 (A) * Uns64 (B); + end "*"; + + function "*" (A : Uns64; B : Uns32) return Uns64 is + begin + return A * Uns64 (B); + end "*"; + + --------- + -- "+" -- + --------- + + function "+" (A, B : Uns32) return Uns64 is + begin + return Uns64 (A) + Uns64 (B); + end "+"; + + function "+" (A : Uns64; B : Uns32) return Uns64 is + begin + return A + Uns64 (B); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (A : Uns64; B : Uns32) return Uns64 is + begin + return A - Uns64 (B); + end "-"; + + --------- + -- "/" -- + --------- + + function "/" (A : Uns64; B : Uns32) return Uns64 is + begin + return A / Uns64 (B); + end "/"; + + ----------- + -- "rem" -- + ----------- + + function "rem" (A : Uns64; B : Uns32) return Uns64 is + begin + return A rem Uns64 (B); + end "rem"; + + -------------------------- + -- Add_With_Ovflo_Check -- + -------------------------- + + function Add_With_Ovflo_Check (X, Y : Int64) return Int64 is + R : constant Int64 := To_Int (To_Uns (X) + To_Uns (Y)); + + begin + if X >= 0 then + if Y < 0 or else R >= 0 then + return R; + end if; + + else -- X < 0 + if Y > 0 or else R < 0 then + return R; + end if; + end if; + + Raise_Error; + end Add_With_Ovflo_Check; + + ------------------- + -- Double_Divide -- + ------------------- + + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) + is + Xu : constant Uns64 := To_Uns (abs X); + Yu : constant Uns64 := To_Uns (abs Y); + + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : constant Uns64 := To_Uns (abs Z); + Zhi : constant Uns32 := Hi (Zu); + Zlo : constant Uns32 := Lo (Zu); + + T1, T2 : Uns64; + Du, Qu, Ru : Uns64; + Den_Pos : Boolean; + + begin + if Yu = 0 or else Zu = 0 then + Raise_Error; + end if; + + -- Compute Y * Z. Note that if the result overflows 64 bits unsigned, + -- then the rounded result is clearly zero (since the dividend is at + -- most 2**63 - 1, the extra bit of precision is nice here!) + + if Yhi /= 0 then + if Zhi /= 0 then + Q := 0; + R := X; + return; + else + T2 := Yhi * Zlo; + end if; + + else + if Zhi /= 0 then + T2 := Ylo * Zhi; + else + T2 := 0; + end if; + end if; + + T1 := Ylo * Zlo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + Q := 0; + R := X; + return; + end if; + + Du := Lo (T2) & Lo (T1); + Qu := Xu / Du; + Ru := Xu rem Du; + + -- Deal with rounding case + + if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then + Qu := Qu + Uns64'(1); + end if; + + -- Set final signs (RM 4.5.5(27-30)) + + Den_Pos := (Y < 0) = (Z < 0); + + -- Case of dividend (X) sign positive + + if X >= 0 then + R := To_Int (Ru); + + if Den_Pos then + Q := To_Int (Qu); + else + Q := -To_Int (Qu); + end if; + + -- Case of dividend (X) sign negative + + else + R := -To_Int (Ru); + + if Den_Pos then + Q := -To_Int (Qu); + else + Q := To_Int (Qu); + end if; + end if; + end Double_Divide; + + -------- + -- Hi -- + -------- + + function Hi (A : Uns64) return Uns32 is + begin + return Uns32 (Shift_Right (A, 32)); + end Hi; + + -------- + -- Lo -- + -------- + + function Lo (A : Uns64) return Uns32 is + begin + return Uns32 (A and 16#FFFF_FFFF#); + end Lo; + + ------------------------------- + -- Multiply_With_Ovflo_Check -- + ------------------------------- + + function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is + Xu : constant Uns64 := To_Uns (abs X); + Xhi : constant Uns32 := Hi (Xu); + Xlo : constant Uns32 := Lo (Xu); + + Yu : constant Uns64 := To_Uns (abs Y); + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + T1, T2 : Uns64; + + begin + if Xhi /= 0 then + if Yhi /= 0 then + Raise_Error; + else + T2 := Xhi * Ylo; + end if; + + else + if Yhi /= 0 then + T2 := Xlo * Yhi; + else + return X * Y; + end if; + end if; + + T1 := Xlo * Ylo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + Raise_Error; + end if; + + T2 := Lo (T2) & Lo (T1); + + if X >= 0 then + if Y >= 0 then + return To_Pos_Int (T2); + else + return To_Neg_Int (T2); + end if; + else -- X < 0 + if Y < 0 then + return To_Pos_Int (T2); + else + return To_Neg_Int (T2); + end if; + end if; + + end Multiply_With_Ovflo_Check; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error is + begin + Raise_Exception (CE, "64-bit arithmetic overflow"); + end Raise_Error; + + ------------------- + -- Scaled_Divide -- + ------------------- + + procedure Scaled_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) + is + Xu : constant Uns64 := To_Uns (abs X); + Xhi : constant Uns32 := Hi (Xu); + Xlo : constant Uns32 := Lo (Xu); + + Yu : constant Uns64 := To_Uns (abs Y); + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : Uns64 := To_Uns (abs Z); + Zhi : Uns32 := Hi (Zu); + Zlo : Uns32 := Lo (Zu); + + D1, D2, D3, D4 : Uns32; + -- The dividend, four digits (D1 is high order) + + Q1, Q2 : Uns32; + -- The quotient, two digits (Q1 is high order) + + S1, S2, S3 : Uns32; + -- Value to subtract, three digits (S1 is high order) + + Qu : Uns64; + Ru : Uns64; + -- Unsigned quotient and remainder + + Scale : Natural; + -- Scaling factor used for multiple-precision divide. Dividend and + -- Divisor are multiplied by 2 ** Scale, and the final remainder + -- is divided by the scaling factor. The reason for this scaling + -- is to allow more accurate estimation of quotient digits. + + T1, T2, T3 : Uns64; + -- Temporary values + + begin + -- First do the multiplication, giving the four digit dividend + + T1 := Xlo * Ylo; + D4 := Lo (T1); + D3 := Hi (T1); + + if Yhi /= 0 then + T1 := Xlo * Yhi; + T2 := D3 + Lo (T1); + D3 := Lo (T2); + D2 := Hi (T1) + Hi (T2); + + if Xhi /= 0 then + T1 := Xhi * Ylo; + T2 := D3 + Lo (T1); + D3 := Lo (T2); + T3 := D2 + Hi (T1); + T3 := T3 + Hi (T2); + D2 := Lo (T3); + D1 := Hi (T3); + + T1 := (D1 & D2) + Uns64'(Xhi * Yhi); + D1 := Hi (T1); + D2 := Lo (T1); + + else + D1 := 0; + end if; + + else + if Xhi /= 0 then + T1 := Xhi * Ylo; + T2 := D3 + Lo (T1); + D3 := Lo (T2); + D2 := Hi (T1) + Hi (T2); + + else + D2 := 0; + end if; + + D1 := 0; + end if; + + -- Now it is time for the dreaded multiple precision division. First + -- an easy case, check for the simple case of a one digit divisor. + + if Zhi = 0 then + if D1 /= 0 or else D2 >= Zlo then + Raise_Error; + + -- Here we are dividing at most three digits by one digit + + else + T1 := D2 & D3; + T2 := Lo (T1 rem Zlo) & D4; + + Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); + Ru := T2 rem Zlo; + end if; + + -- If divisor is double digit and too large, raise error + + elsif (D1 & D2) >= Zu then + Raise_Error; + + -- This is the complex case where we definitely have a double digit + -- divisor and a dividend of at least three digits. We use the classical + -- multiple division algorithm (see section (4.3.1) of Knuth's "The Art + -- of Computer Programming", Vol. 2 for a description (algorithm D). + + else + -- First normalize the divisor so that it has the leading bit on. + -- We do this by finding the appropriate left shift amount. + + Scale := 0; + + if (Zhi and 16#FFFF0000#) = 0 then + Scale := 16; + Zu := Shift_Left (Zu, 16); + end if; + + if (Hi (Zu) and 16#FF00_0000#) = 0 then + Scale := Scale + 8; + Zu := Shift_Left (Zu, 8); + end if; + + if (Hi (Zu) and 16#F000_0000#) = 0 then + Scale := Scale + 4; + Zu := Shift_Left (Zu, 4); + end if; + + if (Hi (Zu) and 16#C000_0000#) = 0 then + Scale := Scale + 2; + Zu := Shift_Left (Zu, 2); + end if; + + if (Hi (Zu) and 16#8000_0000#) = 0 then + Scale := Scale + 1; + Zu := Shift_Left (Zu, 1); + end if; + + Zhi := Hi (Zu); + Zlo := Lo (Zu); + + -- Note that when we scale up the dividend, it still fits in four + -- digits, since we already tested for overflow, and scaling does + -- not change the invariant that (D1 & D2) >= Zu. + + T1 := Shift_Left (D1 & D2, Scale); + D1 := Hi (T1); + T2 := Shift_Left (0 & D3, Scale); + D2 := Lo (T1) or Hi (T2); + T3 := Shift_Left (0 & D4, Scale); + D3 := Lo (T2) or Hi (T3); + D4 := Lo (T3); + + -- Compute first quotient digit. We have to divide three digits by + -- two digits, and we estimate the quotient by dividing the leading + -- two digits by the leading digit. Given the scaling we did above + -- which ensured the first bit of the divisor is set, this gives an + -- estimate of the quotient that is at most two too high. + + if D1 = Zhi then + Q1 := 2 ** 32 - 1; + else + Q1 := Lo ((D1 & D2) / Zhi); + end if; + + -- Compute amount to subtract + + T1 := Q1 * Zlo; + T2 := Q1 * Zhi; + S3 := Lo (T1); + T1 := Hi (T1) + Lo (T2); + S2 := Lo (T1); + S1 := Hi (T1) + Hi (T2); + + -- Adjust quotient digit if it was too high + + loop + exit when S1 < D1; + + if S1 = D1 then + exit when S2 < D2; + + if S2 = D2 then + exit when S3 <= D3; + end if; + end if; + + Q1 := Q1 - 1; + + T1 := (S2 & S3) - Zlo; + S3 := Lo (T1); + T1 := (S1 & S2) - Zhi; + S2 := Lo (T1); + S1 := Hi (T1); + end loop; + + -- Subtract from dividend (note: do not bother to set D1 to + -- zero, since it is no longer needed in the calculation). + + T1 := (D2 & D3) - S3; + D3 := Lo (T1); + T1 := (D1 & Hi (T1)) - S2; + D2 := Lo (T1); + + -- Compute second quotient digit in same manner + + if D2 = Zhi then + Q2 := 2 ** 32 - 1; + else + Q2 := Lo ((D2 & D3) / Zhi); + end if; + + T1 := Q2 * Zlo; + T2 := Q2 * Zhi; + S3 := Lo (T1); + T1 := Hi (T1) + Lo (T2); + S2 := Lo (T1); + S1 := Hi (T1) + Hi (T2); + + loop + exit when S1 < D2; + + if S1 = D2 then + exit when S2 < D3; + + if S2 = D3 then + exit when S3 <= D4; + end if; + end if; + + Q2 := Q2 - 1; + + T1 := (S2 & S3) - Zlo; + S3 := Lo (T1); + T1 := (S1 & S2) - Zhi; + S2 := Lo (T1); + S1 := Hi (T1); + end loop; + + T1 := (D3 & D4) - S3; + D4 := Lo (T1); + T1 := (D2 & Hi (T1)) - S2; + D3 := Lo (T1); + + -- The two quotient digits are now set, and the remainder of the + -- scaled division is in (D3 & D4). To get the remainder for the + -- original unscaled division, we rescale this dividend. + -- We rescale the divisor as well, to make the proper comparison + -- for rounding below. + + Qu := Q1 & Q2; + Ru := Shift_Right (D3 & D4, Scale); + Zu := Shift_Right (Zu, Scale); + end if; + + -- Deal with rounding case + + if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then + Qu := Qu + Uns64 (1); + end if; + + -- Set final signs (RM 4.5.5(27-30)) + + -- Case of dividend (X * Y) sign positive + + if (X >= 0 and then Y >= 0) + or else (X < 0 and then Y < 0) + then + R := To_Pos_Int (Ru); + + if Z > 0 then + Q := To_Pos_Int (Qu); + else + Q := To_Neg_Int (Qu); + end if; + + -- Case of dividend (X * Y) sign negative + + else + R := To_Neg_Int (Ru); + + if Z > 0 then + Q := To_Neg_Int (Qu); + else + Q := To_Pos_Int (Qu); + end if; + end if; + + end Scaled_Divide; + + ------------------------------- + -- Subtract_With_Ovflo_Check -- + ------------------------------- + + function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64 is + R : constant Int64 := To_Int (To_Uns (X) - To_Uns (Y)); + + begin + if X >= 0 then + if Y > 0 or else R >= 0 then + return R; + end if; + + else -- X < 0 + if Y <= 0 or else R < 0 then + return R; + end if; + end if; + + Raise_Error; + end Subtract_With_Ovflo_Check; + + ---------------- + -- To_Neg_Int -- + ---------------- + + function To_Neg_Int (A : Uns64) return Int64 is + R : constant Int64 := -To_Int (A); + + begin + if R <= 0 then + return R; + else + Raise_Error; + end if; + end To_Neg_Int; + + ---------------- + -- To_Pos_Int -- + ---------------- + + function To_Pos_Int (A : Uns64) return Int64 is + R : constant Int64 := To_Int (A); + + begin + if R >= 0 then + return R; + else + Raise_Error; + end if; + end To_Pos_Int; + +end System.Arith_64; diff --git a/gcc/ada/s-arit64.ads b/gcc/ada/s-arit64.ads new file mode 100644 index 00000000000..d32bbaab2a5 --- /dev/null +++ b/gcc/ada/s-arit64.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- Copyright (C) 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 unit provides software routines for doing arithmetic on 64-bit +-- signed integer values in cases where either overflow checking is +-- required, or intermediate results are longer than 64 bits. + +with Interfaces; + +package System.Arith_64 is +pragma Pure (Arith_64); + + subtype Int64 is Interfaces.Integer_64; + + function Add_With_Ovflo_Check (X, Y : Int64) return Int64; + -- Raises Constraint_Error if sum of operands overflows 64 bits, + -- otherwise returns the 64-bit signed integer sum. + + function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64; + -- Raises Constraint_Error if difference of operands overflows 64 + -- bits, otherwise returns the 64-bit signed integer difference. + + function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64; + -- Raises Constraint_Error if product of operands overflows 64 + -- bits, otherwise returns the 64-bit signed integer difference. + + procedure Scaled_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean); + -- Performs the division of (X * Y) / Z, storing the quotient in Q + -- and the remainder in R. Constraint_Error is raised if Z is zero, + -- or if the quotient does not fit in 64-bits. Round indicates if + -- the result should be rounded. If Round is False, then Q, R are + -- the normal quotient and remainder from a truncating division. + -- If Round is True, then Q is the rounded quotient. the remainder + -- R is not affected by the setting of the Round flag. + + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean); + -- Performs the division X / (Y * Z), storing the quotient in Q and + -- the remainder in R. Constraint_Error is raised if Y or Z is zero. + -- Round indicates if the result should be rounded. If Round is False, + -- then Q, R are the normal quotient and remainder from a truncating + -- division. If Round is True, then Q is the rounded quotient. The + -- remainder R is not affected by the setting of the Round flag. The + -- result is known to be in range except for the noted possibility of + -- Y or Z being zero, so no other overflow checks are required. + +end System.Arith_64; diff --git a/gcc/ada/s-assert.adb b/gcc/ada/s-assert.adb new file mode 100644 index 00000000000..c070cc626fa --- /dev/null +++ b/gcc/ada/s-assert.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . A S S E R T I O N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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.Exceptions; + +package body System.Assertions is + + -------------------------- + -- Raise_Assert_Failure -- + -------------------------- + + procedure Raise_Assert_Failure (Msg : String) is + begin + Ada.Exceptions.Raise_Exception (Assert_Failure'Identity, Msg); + end Raise_Assert_Failure; + +end System.Assertions; diff --git a/gcc/ada/s-assert.ads b/gcc/ada/s-assert.ads new file mode 100644 index 00000000000..45fe11c88f3 --- /dev/null +++ b/gcc/ada/s-assert.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . A S S E R T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +package System.Assertions is + + Assert_Failure : exception; + -- Exception raised when assertion fails + + procedure Raise_Assert_Failure (Msg : String); + pragma No_Return (Raise_Assert_Failure); + -- Called to raise Assert_Failure with given message + +end System.Assertions; diff --git a/gcc/ada/s-asthan.adb b/gcc/ada/s-asthan.adb new file mode 100644 index 00000000000..8247ec7a153 --- /dev/null +++ b/gcc/ada/s-asthan.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNT-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S T _ H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1996-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 dummy version used on non-VMS systems + +with Ada.Exceptions; +with Ada.Task_Identification; +with System.Aux_DEC; + +package body System.AST_Handling is + + ------------------------ + -- Create_AST_Handler -- + ------------------------ + + function Create_AST_Handler + (Taskid : Ada.Task_Identification.Task_Id; + Entryno : Natural) + return System.Aux_DEC.AST_Handler + is + begin + Ada.Exceptions.Raise_Exception + (E => Program_Error'Identity, + Message => "AST is implemented only on VMS systems"); + + return System.Aux_DEC.No_AST_Handler; + end Create_AST_Handler; + + procedure Expand_AST_Packet_Pool + (Requested_Packets : in Natural; + Actual_Number : out Natural; + Total_Number : out Natural) + is + begin + Ada.Exceptions.Raise_Exception + (E => Program_Error'Identity, + Message => "AST is implemented only on VMS systems"); + + Actual_Number := 0; + Total_Number := 0; + end Expand_AST_Packet_Pool; + +end System.AST_Handling; diff --git a/gcc/ada/s-asthan.ads b/gcc/ada/s-asthan.ads new file mode 100644 index 00000000000..4f19483a26e --- /dev/null +++ b/gcc/ada/s-asthan.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . A S T _ H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1996 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Runtime support for Handling of AST's (Used on VMS implementations only) + + +with Ada.Task_Identification; +with System; +with System.Aux_DEC; + +package System.AST_Handling is + + function Create_AST_Handler + (Taskid : Ada.Task_Identification.Task_Id; + Entryno : Natural) + return System.Aux_DEC.AST_Handler; + -- This function implements the appropriate semantics for a use of the + -- AST_Entry pragma. See body for details of implementation approach. + -- The parameters are the Task_Id for the task containing the entry + -- and the entry Index for the specified entry. + + procedure Expand_AST_Packet_Pool + (Requested_Packets : in Natural; + Actual_Number : out Natural; + Total_Number : out Natural); + -- This function takes a request for zero or more extra AST packets and + -- returns the number actually added to the pool and the total number + -- now available or in use. + -- This function is not yet fully implemented. + +end System.AST_Handling; diff --git a/gcc/ada/s-atacco.adb b/gcc/ada/s-atacco.adb new file mode 100644 index 00000000000..7d2842cfcba --- /dev/null +++ b/gcc/ada/s-atacco.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with Unchecked_Conversion; +package body System.Address_To_Access_Conversions is + + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Value : Object_Pointer) return Address is + begin + if Value = null then + return Null_Address; + else + return Value.all'Address; + end if; + end To_Address; + + ---------------- + -- To_Pointer -- + ---------------- + + function To_Pointer (Value : Address) return Object_Pointer is + function A_To_P is new Unchecked_Conversion (Address, Object_Pointer); + + begin + return A_To_P (Value); + end To_Pointer; + +end System.Address_To_Access_Conversions; diff --git a/gcc/ada/s-atacco.ads b/gcc/ada/s-atacco.ads new file mode 100644 index 00000000000..e5db1ee268a --- /dev/null +++ b/gcc/ada/s-atacco.ads @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N 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. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + +package System.Address_To_Access_Conversions is +pragma Preelaborate (Address_To_Access_Conversions); + + type Object_Pointer is access all Object; + for Object_Pointer'Size use Standard'Address_Size; + + function To_Pointer (Value : Address) return Object_Pointer; + function To_Address (Value : Object_Pointer) return Address; + + pragma Convention (Intrinsic, To_Pointer); + pragma Convention (Intrinsic, To_Address); + +end System.Address_To_Access_Conversions; diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb new file mode 100644 index 00000000000..e16cf6acbb0 --- /dev/null +++ b/gcc/ada/s-auxdec.adb @@ -0,0 +1,709 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off alpha ordering check on subprograms, this unit is laid +-- out to correspond to the declarations in the DEC 83 System unit. + +with System.Soft_Links; + +package body System.Aux_DEC is + + package SSL renames System.Soft_Links; + + ----------------------------------- + -- Operations on Largest_Integer -- + ----------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type LIU is mod 2 ** Largest_Integer'Size; + -- Unsigned type of same length as Largest_Integer + + function To_LI is new Unchecked_Conversion (LIU, Largest_Integer); + function From_LI is new Unchecked_Conversion (Largest_Integer, LIU); + + function "not" (Left : Largest_Integer) return Largest_Integer is + begin + return To_LI (not From_LI (Left)); + end "not"; + + function "and" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) and From_LI (Right)); + end "and"; + + function "or" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) or From_LI (Right)); + end "or"; + + function "xor" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) xor From_LI (Right)); + end "xor"; + + -------------------------------------- + -- Arithmetic Operations on Address -- + -------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + Asiz : constant Integer := Integer (Address'Size) - 1; + + type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; + -- Signed type of same size as Address + + function To_A is new Unchecked_Conversion (SA, Address); + function From_A is new Unchecked_Conversion (Address, SA); + + function "+" (Left : Address; Right : Integer) return Address is + begin + return To_A (From_A (Left) + SA (Right)); + end "+"; + + function "+" (Left : Integer; Right : Address) return Address is + begin + return To_A (SA (Left) + From_A (Right)); + end "+"; + + function "-" (Left : Address; Right : Address) return Integer is + pragma Unsuppress (All_Checks); + -- Because this can raise Constraint_Error for 64-bit addresses + + begin + return Integer (From_A (Left - Right)); + end "-"; + + function "-" (Left : Address; Right : Integer) return Address is + begin + return To_A (From_A (Left) - SA (Right)); + end "-"; + + ------------------------ + -- Fetch_From_Address -- + ------------------------ + + function Fetch_From_Address (A : Address) return Target is + type T_Ptr is access all Target; + function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + + begin + return Ptr.all; + end Fetch_From_Address; + + ----------------------- + -- Assign_To_Address -- + ----------------------- + + procedure Assign_To_Address (A : Address; T : Target) is + type T_Ptr is access all Target; + function To_T_Ptr is new Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + + begin + Ptr.all := T; + end Assign_To_Address; + + --------------------------------- + -- Operations on Unsigned_Byte -- + --------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type BU is mod 2 ** Unsigned_Byte'Size; + -- Unsigned type of same length as Unsigned_Byte + + function To_B is new Unchecked_Conversion (BU, Unsigned_Byte); + function From_B is new Unchecked_Conversion (Unsigned_Byte, BU); + + function "not" (Left : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (not From_B (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) and From_B (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) or From_B (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) xor From_B (Right)); + end "xor"; + + --------------------------------- + -- Operations on Unsigned_Word -- + --------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type WU is mod 2 ** Unsigned_Word'Size; + -- Unsigned type of same length as Unsigned_Word + + function To_W is new Unchecked_Conversion (WU, Unsigned_Word); + function From_W is new Unchecked_Conversion (Unsigned_Word, WU); + + function "not" (Left : Unsigned_Word) return Unsigned_Word is + begin + return To_W (not From_W (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) and From_W (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) or From_W (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) xor From_W (Right)); + end "xor"; + + ------------------------------------- + -- Operations on Unsigned_Longword -- + ------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type LWU is mod 2 ** Unsigned_Longword'Size; + -- Unsigned type of same length as Unsigned_Longword + + function To_LW is new Unchecked_Conversion (LWU, Unsigned_Longword); + function From_LW is new Unchecked_Conversion (Unsigned_Longword, LWU); + + function "not" (Left : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (not From_LW (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) and From_LW (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) or From_LW (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) xor From_LW (Right)); + end "xor"; + + ------------------------------- + -- Operations on Unsigned_32 -- + ------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type U32 is mod 2 ** Unsigned_32'Size; + -- Unsigned type of same length as Unsigned_32 + + function To_U32 is new Unchecked_Conversion (U32, Unsigned_32); + function From_U32 is new Unchecked_Conversion (Unsigned_32, U32); + + function "not" (Left : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (not From_U32 (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) and From_U32 (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) or From_U32 (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) xor From_U32 (Right)); + end "xor"; + + ------------------------------------- + -- Operations on Unsigned_Quadword -- + ------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size + -- Unsigned type of same length as Unsigned_Quadword + + function To_QW is new Unchecked_Conversion (QWU, Unsigned_Quadword); + function From_QW is new Unchecked_Conversion (Unsigned_Quadword, QWU); + + function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (not From_QW (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) and From_QW (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) or From_QW (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) xor From_QW (Right)); + end "xor"; + + ----------------------- + -- Clear_Interlocked -- + ----------------------- + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := False; + SSL.Unlock_Task.all; + end Clear_Interlocked; + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : in Natural; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := False; + Success_Flag := True; + SSL.Unlock_Task.all; + end Clear_Interlocked; + + --------------------- + -- Set_Interlocked -- + --------------------- + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := True; + SSL.Unlock_Task.all; + end Set_Interlocked; + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : in Natural; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := True; + Success_Flag := True; + SSL.Unlock_Task.all; + end Set_Interlocked; + + --------------------- + -- Add_Interlocked -- + --------------------- + + procedure Add_Interlocked + (Addend : in Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer) + is + begin + SSL.Lock_Task.all; + Augend.Value := Augend.Value + Addend; + + if Augend.Value < 0 then + Sign := -1; + elsif Augend.Value > 0 then + Sign := +1; + else + Sign := 0; + end if; + + SSL.Unlock_Task.all; + end Add_Interlocked; + + ---------------- + -- Add_Atomic -- + ---------------- + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : in Integer) + is + begin + SSL.Lock_Task.all; + To.Value := To.Value + Amount; + SSL.Unlock_Task.all; + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := To.Value + Amount; + Success_Flag := True; + SSL.Unlock_Task.all; + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : in Long_Integer) + is + begin + SSL.Lock_Task.all; + To.Value := To.Value + Amount; + SSL.Unlock_Task.all; + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := To.Value + Amount; + Success_Flag := True; + SSL.Unlock_Task.all; + end Add_Atomic; + + ---------------- + -- And_Atomic -- + ---------------- + + type IU is mod 2 ** Integer'Size; + type LU is mod 2 ** Long_Integer'Size; + + function To_IU is new Unchecked_Conversion (Integer, IU); + function From_IU is new Unchecked_Conversion (IU, Integer); + + function To_LU is new Unchecked_Conversion (Long_Integer, LU); + function From_LU is new Unchecked_Conversion (LU, Long_Integer); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : in Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_IU (To_IU (To.Value) and To_IU (From)); + SSL.Unlock_Task.all; + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Integer; + From : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_IU (To_IU (To.Value) and To_IU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_LU (To_LU (To.Value) and To_LU (From)); + SSL.Unlock_Task.all; + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_LU (To_LU (To.Value) and To_LU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end And_Atomic; + + --------------- + -- Or_Atomic -- + --------------- + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : in Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_IU (To_IU (To.Value) or To_IU (From)); + SSL.Unlock_Task.all; + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_IU (To_IU (To.Value) or To_IU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_LU (To_LU (To.Value) or To_LU (From)); + SSL.Unlock_Task.all; + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_LU (To_LU (To.Value) or To_LU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end Or_Atomic; + + ------------------------------------ + -- Declarations for Queue Objects -- + ------------------------------------ + + type QR; + + type QR_Ptr is access QR; + + type QR is record + Forward : QR_Ptr; + Backward : QR_Ptr; + end record; + + function To_QR_Ptr is new Unchecked_Conversion (Address, QR_Ptr); + function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address); + + ------------ + -- Insqhi -- + ------------ + + procedure Insqhi + (Item : in Address; + Header : in Address; + Status : out Insq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Next : constant QR_Ptr := Hedr.Forward; + Itm : constant QR_Ptr := To_QR_Ptr (Item); + + begin + SSL.Lock_Task.all; + + Itm.Forward := Next; + Itm.Backward := Hedr; + Hedr.Forward := Itm; + + if Next = null then + Status := OK_First; + + else + Next.Backward := Itm; + Status := OK_Not_First; + end if; + + SSL.Unlock_Task.all; + end Insqhi; + + ------------ + -- Remqhi -- + ------------ + + procedure Remqhi + (Header : in Address; + Item : out Address; + Status : out Remq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Next : constant QR_Ptr := Hedr.Forward; + + begin + SSL.Lock_Task.all; + + Item := From_QR_Ptr (Next); + + if Next = null then + Status := Fail_Was_Empty; + + else + Hedr.Forward := To_QR_Ptr (Item).Forward; + + if Hedr.Forward = null then + Status := OK_Empty; + + else + Hedr.Forward.Backward := Hedr; + Status := OK_Not_Empty; + end if; + end if; + + SSL.Unlock_Task.all; + end Remqhi; + + ------------ + -- Insqti -- + ------------ + + procedure Insqti + (Item : in Address; + Header : in Address; + Status : out Insq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Prev : constant QR_Ptr := Hedr.Backward; + Itm : constant QR_Ptr := To_QR_Ptr (Item); + + begin + SSL.Lock_Task.all; + + Itm.Backward := Prev; + Itm.Forward := Hedr; + Hedr.Backward := Itm; + + if Prev = null then + Status := OK_First; + + else + Prev.Forward := Itm; + Status := OK_Not_First; + end if; + + SSL.Unlock_Task.all; + end Insqti; + + ------------ + -- Remqti -- + ------------ + + procedure Remqti + (Header : in Address; + Item : out Address; + Status : out Remq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Prev : constant QR_Ptr := Hedr.Backward; + + begin + SSL.Lock_Task.all; + + Item := From_QR_Ptr (Prev); + + if Prev = null then + Status := Fail_Was_Empty; + + else + Hedr.Backward := To_QR_Ptr (Item).Backward; + + if Hedr.Backward = null then + Status := OK_Empty; + + else + Hedr.Backward.Forward := Hedr; + Status := OK_Not_Empty; + end if; + end if; + + SSL.Unlock_Task.all; + end Remqti; + +end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads new file mode 100644 index 00000000000..fc1f4ac653a --- /dev/null +++ b/gcc/ada/s-auxdec.ads @@ -0,0 +1,556 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.24 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains definitions that are designed to be compatible +-- with the extra definitions in package System for DEC Ada implementations. + +-- These definitions can be used directly by withing this package, or merged +-- with System using pragma Extend_System (Aux_DEC) + +with Unchecked_Conversion; + +package System.Aux_DEC is +pragma Elaborate_Body (Aux_DEC); + + type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; + for Integer_8'Size use 8; + + type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1; + for Integer_16'Size use 16; + + type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; + for Integer_32'Size use 32; + + type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1; + for Integer_64'Size use 64; + + type Largest_Integer is range Min_Int .. Max_Int; + + type AST_Handler is limited private; + + No_AST_Handler : constant AST_Handler; + + type Type_Class is + (Type_Class_Enumeration, + Type_Class_Integer, + Type_Class_Fixed_Point, + Type_Class_Floating_Point, + Type_Class_Array, + Type_Class_Record, + Type_Class_Access, + Type_Class_Task, -- also in Ada 95 protected + Type_Class_Address); + + function "not" (Left : Largest_Integer) return Largest_Integer; + function "and" (Left, Right : Largest_Integer) return Largest_Integer; + function "or" (Left, Right : Largest_Integer) return Largest_Integer; + function "xor" (Left, Right : Largest_Integer) return Largest_Integer; + + Address_Zero : constant Address; + No_Addr : constant Address; + Address_Size : constant := Standard'Address_Size; + + function "+" (Left : Address; Right : Integer) return Address; + function "+" (Left : Integer; Right : Address) return Address; + function "-" (Left : Address; Right : Address) return Integer; + function "-" (Left : Address; Right : Integer) return Address; + + generic + type Target is private; + function Fetch_From_Address (A : Address) return Target; + + generic + type Target is private; + procedure Assign_To_Address (A : Address; T : Target); + + -- Floating point type declarations for VAX floating point data types + + pragma Warnings (Off); + + type F_Float is digits 6; + pragma Float_Representation (VAX_Float, F_Float); + + type D_Float is digits 9; + pragma Float_Representation (Vax_Float, D_Float); + + type G_Float is digits 15; + pragma Float_Representation (Vax_Float, G_Float); + + -- Floating point type declarations for IEEE floating point data types + + type IEEE_Single_Float is digits 6; + pragma Float_Representation (IEEE_Float, IEEE_Single_Float); + + type IEEE_Double_Float is digits 15; + pragma Float_Representation (IEEE_Float, IEEE_Double_Float); + + pragma Warnings (On); + + Non_Ada_Error : exception; + + -- Hardware-oriented types and functions + + type Bit_Array is array (Integer range <>) of Boolean; + pragma Pack (Bit_Array); + + subtype Bit_Array_8 is Bit_Array (0 .. 7); + subtype Bit_Array_16 is Bit_Array (0 .. 15); + subtype Bit_Array_32 is Bit_Array (0 .. 31); + subtype Bit_Array_64 is Bit_Array (0 .. 63); + + type Unsigned_Byte is range 0 .. 255; + for Unsigned_Byte'Size use 8; + + function "not" (Left : Unsigned_Byte) return Unsigned_Byte; + function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + + function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte; + function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8; + + type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte; + + type Unsigned_Word is range 0 .. 65535; + for Unsigned_Word'Size use 16; + + function "not" (Left : Unsigned_Word) return Unsigned_Word; + function "and" (Left, Right : Unsigned_Word) return Unsigned_Word; + function "or" (Left, Right : Unsigned_Word) return Unsigned_Word; + function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word; + + function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word; + function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16; + + type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word; + + type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647; + for Unsigned_Longword'Size use 32; + + function "not" (Left : Unsigned_Longword) return Unsigned_Longword; + function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + + function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword; + function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32; + + type Unsigned_Longword_Array is + array (Integer range <>) of Unsigned_Longword; + + type Unsigned_32 is range 0 .. 4_294_967_295; + for Unsigned_32'Size use 32; + + function "not" (Left : Unsigned_32) return Unsigned_32; + function "and" (Left, Right : Unsigned_32) return Unsigned_32; + function "or" (Left, Right : Unsigned_32) return Unsigned_32; + function "xor" (Left, Right : Unsigned_32) return Unsigned_32; + + function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32; + function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32; + + type Unsigned_Quadword is record + L0 : Unsigned_Longword; + L1 : Unsigned_Longword; + end record; + + for Unsigned_Quadword'Size use 64; + for Unsigned_Quadword'Alignment use + Integer'Min (8, Standard'Maximum_Alignment); + + function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword; + function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + + function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword; + function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64; + + type Unsigned_Quadword_Array is + array (Integer range <>) of Unsigned_Quadword; + + function To_Address (X : Integer) return Address; + pragma Pure_Function (To_Address); + + function To_Address_Long (X : Unsigned_Longword) return Address; + pragma Pure_Function (To_Address_Long); + + function To_Integer (X : Address) return Integer; + + function To_Unsigned_Longword (X : Address) return Unsigned_Longword; + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; + + -- Conventional names for static subtypes of type UNSIGNED_LONGWORD + + subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1-1; + subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2-1; + subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3-1; + subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4-1; + subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5-1; + subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6-1; + subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7-1; + subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8-1; + subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9-1; + subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10-1; + subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11-1; + subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12-1; + subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13-1; + subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14-1; + subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15-1; + subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16-1; + subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17-1; + subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18-1; + subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19-1; + subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20-1; + subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21-1; + subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22-1; + subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23-1; + subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24-1; + subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25-1; + subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26-1; + subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27-1; + subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28-1; + subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29-1; + subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30-1; + subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31-1; + + -- Function for obtaining global symbol values + + function Import_Value (Symbol : String) return Unsigned_Longword; + function Import_Address (Symbol : String) return Address; + function Import_Largest_Value (Symbol : String) return Largest_Integer; + + pragma Import (Intrinsic, Import_Value); + pragma Import (Intrinsic, Import_Address); + pragma Import (Intrinsic, Import_Largest_Value); + + -- For the following declarations, note that the declaration without + -- a Retry_Count parameter means to retry infinitely. A value of zero + -- for the Retry_Count parameter means do not retry. + + -- Interlocked-instruction procedures + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean); + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean); + + type Aligned_Word is record + Value : Short_Integer; + end record; + + for Aligned_Word'Alignment use + Integer'Min (2, Standard'Maximum_Alignment); + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : in Natural; + Success_Flag : out Boolean); + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : in Natural; + Success_Flag : out Boolean); + + procedure Add_Interlocked + (Addend : in Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer); + + type Aligned_Integer is record + Value : Integer; + end record; + + for Aligned_Integer'Alignment use + Integer'Min (4, Standard'Maximum_Alignment); + + type Aligned_Long_Integer is record + Value : Long_Integer; + end record; + + for Aligned_Long_Integer'Alignment use + Integer'Min (8, Standard'Maximum_Alignment); + + -- For the following declarations, note that the declaration without + -- a Retry_Count parameter mean to retry infinitely. A value of zero + -- for the Retry_Count means do not retry. + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : in Integer); + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : in Long_Integer); + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : in Integer); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer); + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : in Integer); + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : in Integer; + Retry_Count : in Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer); + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : in Long_Integer; + Retry_Count : in Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + type Insq_Status is + (Fail_No_Lock, OK_Not_First, OK_First); + + for Insq_Status use + (Fail_No_Lock => -1, + OK_Not_First => 0, + OK_First => +1); + + type Remq_Status is ( + Fail_No_Lock, + Fail_Was_Empty, + OK_Not_Empty, + OK_Empty); + + for Remq_Status use + (Fail_No_Lock => -1, + Fail_Was_Empty => 0, + OK_Not_Empty => +1, + OK_Empty => +2); + + procedure Insqhi + (Item : in Address; + Header : in Address; + Status : out Insq_Status); + + procedure Remqhi + (Header : in Address; + Item : out Address; + Status : out Remq_Status); + + procedure Insqti + (Item : in Address; + Header : in Address; + Status : out Insq_Status); + + procedure Remqti + (Header : in Address; + Item : out Address; + Status : out Remq_Status); + +private + + Address_Zero : constant Address := Null_Address; + No_Addr : constant Address := Null_Address; + + -- An AST_Handler value is from a typing point of view simply a pointer + -- to a procedure taking a single 64bit parameter. However, this + -- is a bit misleading, because the data that this pointer references is + -- highly stylized. See body of System.AST_Handling for full details. + + type AST_Handler is access procedure (Param : Long_Integer); + No_AST_Handler : constant AST_Handler := null; + + -- Other operators have incorrect profiles. It would be nice to make + -- them intrinsic, since the backend can handle them, but the front + -- end is not prepared to deal with them, so at least inline them. + + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline ("not"); + pragma Inline ("and"); + pragma Inline ("or"); + pragma Inline ("xor"); + + -- Other inlined subprograms + + pragma Inline (Fetch_From_Address); + pragma Inline (Assign_To_Address); + + -- Provide proper unchecked conversion definitions for transfer + -- functions. Note that we need this level of indirection because + -- the formal parameter name is X and not Source (and this is indeed + -- detectable by a program) + + function To_Unsigned_Byte_A is new + Unchecked_Conversion (Bit_Array_8, Unsigned_Byte); + + function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte + renames To_Unsigned_Byte_A; + + function To_Bit_Array_8_A is new + Unchecked_Conversion (Unsigned_Byte, Bit_Array_8); + + function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8 + renames To_Bit_Array_8_A; + + function To_Unsigned_Word_A is new + Unchecked_Conversion (Bit_Array_16, Unsigned_Word); + + function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word + renames To_Unsigned_Word_A; + + function To_Bit_Array_16_A is new + Unchecked_Conversion (Unsigned_Word, Bit_Array_16); + + function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16 + renames To_Bit_Array_16_A; + + function To_Unsigned_Longword_A is new + Unchecked_Conversion (Bit_Array_32, Unsigned_Longword); + + function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + function To_Bit_Array_32_A is new + Unchecked_Conversion (Unsigned_Longword, Bit_Array_32); + + function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32 + renames To_Bit_Array_32_A; + + function To_Unsigned_32_A is new + Unchecked_Conversion (Bit_Array_32, Unsigned_32); + + function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32 + renames To_Unsigned_32_A; + + function To_Bit_Array_32_A is new + Unchecked_Conversion (Unsigned_32, Bit_Array_32); + + function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32 + renames To_Bit_Array_32_A; + + function To_Unsigned_Quadword_A is new + Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword); + + function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword + renames To_Unsigned_Quadword_A; + + function To_Bit_Array_64_A is new + Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64); + + function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64 + renames To_Bit_Array_64_A; + + pragma Warnings (Off); + -- Turn warnings off. This is needed for systems with 64-bit integers, + -- where some of these operations are of dubious meaning, but we do not + -- want warnings when we compile on such systems. + + function To_Address_A is new + Unchecked_Conversion (Integer, Address); + pragma Pure_Function (To_Address_A); + + function To_Address (X : Integer) return Address + renames To_Address_A; + pragma Pure_Function (To_Address); + + function To_Address_Long_A is new + Unchecked_Conversion (Unsigned_Longword, Address); + pragma Pure_Function (To_Address_Long_A); + + function To_Address_Long (X : Unsigned_Longword) return Address + renames To_Address_Long_A; + pragma Pure_Function (To_Address_Long); + + function To_Integer_A is new + Unchecked_Conversion (Address, Integer); + + function To_Integer (X : Address) return Integer + renames To_Integer_A; + + function To_Unsigned_Longword_A is new + Unchecked_Conversion (Address, Unsigned_Longword); + + function To_Unsigned_Longword (X : Address) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + function To_Unsigned_Longword_A is new + Unchecked_Conversion (AST_Handler, Unsigned_Longword); + + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + pragma Warnings (On); + +end System.Aux_DEC; diff --git a/gcc/ada/s-bitops.adb b/gcc/ada/s-bitops.adb new file mode 100644 index 00000000000..6b5538c30d4 --- /dev/null +++ b/gcc/ada/s-bitops.adb @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . B I T _ O P S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1996-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 GNAT.Exceptions; use GNAT.Exceptions; +with System; use System; +with System.Unsigned_Types; use System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Bit_Ops is + + subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive); + -- Unconstrained array used to interprete the address values. We use the + -- unaligned version always, since this will handle both the aligned and + -- unaligned cases, and we always do these operations by bytes anyway. + -- Note: we use a ones origin array here so that the computations of the + -- length in bytes work correctly (give a non-negative value) for the + -- case of zero length bit strings). + + type Bits is access Bits_Array; + -- This is the actual type into which address values are converted + + function To_Bits is new Unchecked_Conversion (Address, Bits); + + LE : constant := Standard'Default_Bit_Order; + -- Static constant set to 0 for big-endian, 1 for little-endian + + -- The following is an array of masks used to mask the final byte, either + -- at the high end (big-endian case) or the low end (little-endian case). + + Masks : constant array (1 .. 7) of Packed_Byte := ( + (1 - LE) * 2#1000_0000# + LE * 2#0000_0001#, + (1 - LE) * 2#1100_0000# + LE * 2#0000_0011#, + (1 - LE) * 2#1110_0000# + LE * 2#0000_0111#, + (1 - LE) * 2#1111_0000# + LE * 2#0000_1111#, + (1 - LE) * 2#1111_1000# + LE * 2#0001_1111#, + (1 - LE) * 2#1111_1100# + LE * 2#0011_1111#, + (1 - LE) * 2#1111_1110# + LE * 2#0111_1111#); + + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Raise_Error; + -- Raise Constraint_Error, complaining about unequal lengths + + ------------- + -- Bit_And -- + ------------- + + procedure Bit_And + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : Address) + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + ResultB : constant Bits := To_Bits (Result); + + begin + if Llen /= Rlen then + Raise_Error; + end if; + + for J in 1 .. (Rlen + 7) / 8 loop + ResultB (J) := LeftB (J) and RightB (J); + end loop; + end Bit_And; + + ------------ + -- Bit_Eq -- + ------------ + + function Bit_Eq + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural) + return Boolean + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + + begin + if Llen /= Rlen then + return False; + + else + declare + BLen : constant Natural := Llen / 8; + Bitc : constant Natural := Llen mod 8; + + begin + if Llen /= Rlen then + return False; + + elsif LeftB (1 .. BLen) /= RightB (1 .. BLen) then + return False; + + elsif Bitc /= 0 then + return + ((LeftB (BLen + 1) xor RightB (BLen + 1)) + and Masks (Bitc)) = 0; + + else -- Bitc = 0 + return True; + end if; + end; + end if; + end Bit_Eq; + + ------------- + -- Bit_Not -- + ------------- + + procedure Bit_Not + (Opnd : System.Address; + Len : Natural; + Result : System.Address) + is + OpndB : constant Bits := To_Bits (Opnd); + ResultB : constant Bits := To_Bits (Result); + + begin + for J in 1 .. (Len + 7) / 8 loop + ResultB (J) := not OpndB (J); + end loop; + end Bit_Not; + + ------------ + -- Bit_Or -- + ------------ + + procedure Bit_Or + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : Address) + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + ResultB : constant Bits := To_Bits (Result); + + begin + if Llen /= Rlen then + Raise_Error; + end if; + + for J in 1 .. (Rlen + 7) / 8 loop + ResultB (J) := LeftB (J) or RightB (J); + end loop; + end Bit_Or; + + ------------- + -- Bit_Xor -- + ------------- + + procedure Bit_Xor + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : Address) + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + ResultB : constant Bits := To_Bits (Result); + + begin + if Llen /= Rlen then + Raise_Error; + end if; + + for J in 1 .. (Rlen + 7) / 8 loop + ResultB (J) := LeftB (J) xor RightB (J); + end loop; + end Bit_Xor; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error is + begin + Raise_Exception (CE, "unequal lengths in logical operation"); + end Raise_Error; + +end System.Bit_Ops; diff --git a/gcc/ada/s-bitops.ads b/gcc/ada/s-bitops.ads new file mode 100644 index 00000000000..e925247e746 --- /dev/null +++ b/gcc/ada/s-bitops.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . B I T _ O P S -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- Operations on packed bit strings + +with System; + +package System.Bit_Ops is + + -- Note: in all the following routines, the System.Address parameters + -- represent the address of the first byte of an array used to represent + -- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4}) + -- The length in bits is passed as a separate parameter. + + procedure Bit_And + (Left : System.Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : System.Address); + -- Bitwise "and" of given bit string with result being placed in Result. + -- The or operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Left, Right + -- and Result always have the same length in bits (Len). + + function Bit_Eq + (Left : System.Address; + Llen : Natural; + Right : System.Address; + Rlen : Natural) + return Boolean; + -- Left and Right are the addresses of two bit packed arrays with Llen + -- and Rlen being the respective length in bits. The routine compares the + -- two bit strings for equality, being careful not to include the unused + -- bits in the final byte. Note that the result is always False if Rlen + -- is not equal to Llen. + + procedure Bit_Not + (Opnd : System.Address; + Len : Natural; + Result : System.Address); + -- Bitwise "not" of given bit string with result being placed in Result. + -- The not operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Result and + -- Opnd always have the same length in bits (Len). + + procedure Bit_Or + (Left : System.Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : System.Address); + -- Bitwise "or" of given bit string with result being placed in Result. + -- The or operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Left, Right + -- and Result always have the same length in bits (Len). + + procedure Bit_Xor + (Left : System.Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : System.Address); + -- Bitwise "xor" of given bit string with result being placed in Result. + -- The or operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Left, Right + -- and Result always have the same length in bits (Len). + +end System.Bit_Ops; diff --git a/gcc/ada/s-chepoo.ads b/gcc/ada/s-chepoo.ads new file mode 100644 index 00000000000..bf368858b8e --- /dev/null +++ b/gcc/ada/s-chepoo.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . C H E C K E D _ P O O L S -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Storage_Pools; +package System.Checked_Pools is + + type Checked_Pool is abstract + new System.Storage_Pools.Root_Storage_Pool with private; + -- Equivalent of storage pools with the addition that Dereference is + -- called on each implicit or explicit dereference of a pointer which + -- has such a storage pool + + procedure Allocate + (Pool : in out Checked_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; + Alignment : in System.Storage_Elements.Storage_Count) + is abstract; + + procedure Deallocate + (Pool : in out Checked_Pool; + Storage_Address : in Address; + Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; + Alignment : in System.Storage_Elements.Storage_Count) + is abstract; + + function Storage_Size + (Pool : Checked_Pool) + return System.Storage_Elements.Storage_Count + is abstract; + + procedure Dereference + (Pool : in out Checked_Pool; + Storage_Address : in Address; + Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; + Alignment : in System.Storage_Elements.Storage_Count) + is abstract; + -- Called each time a pointer to a checked pool is dereferenced + +private + type Checked_Pool is abstract + new System.Storage_Pools.Root_Storage_Pool with null record; +end System.Checked_Pools; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb new file mode 100644 index 00000000000..1aeb84149a4 --- /dev/null +++ b/gcc/ada/s-direio.adb @@ -0,0 +1,377 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . D I R E C T _ I O -- +-- -- +-- 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.IO_Exceptions; use Ada.IO_Exceptions; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.File_IO; +with System.Soft_Links; +with Unchecked_Deallocation; + +package body System.Direct_IO is + + package FIO renames System.File_IO; + package SSL renames System.Soft_Links; + + subtype AP is FCB.AFCB_Ptr; + 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 : Direct_AFCB) return FCB.AFCB_Ptr is + begin + return new Direct_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + -- No special processing required for Direct_IO close + + procedure AFCB_Close (File : access Direct_AFCB) is + begin + null; + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : access Direct_AFCB) is + + type FCB_Ptr is access all Direct_AFCB; + + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Unchecked_Deallocation (Direct_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : in FCB.File_Mode := FCB.Inout_File; + Name : in String := ""; + Form : in String := "") + is + File_Control_Block : Direct_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'D', + Creat => True, + Text => False); + end Create; + + ----------------- + -- 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; + + ----------- + -- Index -- + ----------- + + function Index (File : in File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return Count (File.Index); + end Index; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in FCB.File_Mode; + Name : in String; + Form : in String := "") + is + File_Control_Block : Direct_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'D', + Creat => False, + Text => False); + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : in File_Type; + Item : Address; + Size : in Interfaces.C_Streams.size_t; + From : in Positive_Count) + is + begin + Set_Index (File, From); + Read (File, Item, Size); + end Read; + + procedure Read + (File : in File_Type; + Item : Address; + Size : in Interfaces.C_Streams.size_t) + is + 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, Size); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + else + FIO.Read_Buf (AP (File), Item, Size); + end if; + + File.Index := File.Index + 1; + + -- Set last operation to read, unless we did not read a full record + -- (happens with the variant record case) in which case we set the + -- last operation as other, to force the file position to be reset + -- on the next read. + + if File.Bytes = Size then + File.Last_Op := Op_Read; + else + File.Last_Op := Op_Other; + end if; + end Read; + + -- The following is the required overriding for Stream.Read, which is + -- not used, since we do not do Stream operations on Direct_IO files. + + procedure Read + (File : in out Direct_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + raise Program_Error; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode) is + begin + FIO.Reset (AP (File), Mode); + File.Index := 1; + File.Last_Op := Op_Read; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + FIO.Reset (AP (File)); + File.Index := 1; + File.Last_Op := Op_Read; + 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_Position -- + ------------------ + + procedure Set_Position (File : in File_Type) is + begin + if fseek + (File.Stream, long (File.Bytes) * + 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)); + File.Last_Op := Op_Other; + + if fseek (File.Stream, 0, SEEK_END) /= 0 then + raise Device_Error; + end if; + + return Count (ftell (File.Stream) / long (File.Bytes)); + end Size; + + ----------- + -- Write -- + ----------- + + procedure Write + (File : File_Type; + Item : Address; + Size : in Interfaces.C_Streams.size_t; + Zeroes : System.Storage_Elements.Storage_Array) + + is + procedure Do_Write; + -- Do the actual write + + procedure Do_Write is + begin + FIO.Write_Buf (AP (File), Item, Size); + + -- If we did not write the whole record (happens with the variant + -- record case), then fill out the rest of the record with zeroes. + -- This is cleaner in any case, and is required for the last + -- record, since otherwise the length of the file is wrong. + + if File.Bytes > Size then + FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size); + end if; + end Do_Write; + + -- Start of processing for Write + + 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); + Do_Write; + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + else + Do_Write; + end if; + + File.Index := File.Index + 1; + + -- Set last operation to write, unless we did not read a full record + -- (happens with the variant record case) in which case we set the + -- last operation as other, to force the file position to be reset + -- on the next write. + + if File.Bytes = Size then + File.Last_Op := Op_Write; + else + File.Last_Op := Op_Other; + end if; + end Write; + + -- The following is the required overriding for Stream.Write, which is + -- not used, since we do not do Stream operations on Direct_IO files. + + procedure Write + (File : in out Direct_AFCB; + Item : in Ada.Streams.Stream_Element_Array) + is + begin + raise Program_Error; + end Write; + +end System.Direct_IO; diff --git a/gcc/ada/s-direio.ads b/gcc/ada/s-direio.ads new file mode 100644 index 00000000000..333a8046188 --- /dev/null +++ b/gcc/ada/s-direio.ads @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- 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 declaration of the control block used for +-- Direct_IO. This must be declared at the outer library level. It also +-- contains code that is shared between instances of Direct_IO. + +with Interfaces.C_Streams; +with Ada.Streams; +with System.File_Control_Block; +with System.Storage_Elements; + +package System.Direct_IO is + + package FCB renames System.File_Control_Block; + + type Operation is (Op_Read, Op_Write, Op_Other); + -- Type used to record last operation (to optimize sequential operations) + + subtype Count is Interfaces.C_Streams.long; + -- The Count type in each instantiation is derived from this type + + subtype Positive_Count is Count range 1 .. Count'Last; + + type Direct_AFCB is new FCB.AFCB with record + Index : Count := 1; + -- Current Index value + + Bytes : Interfaces.C_Streams.size_t; + -- Length of item in bytes (set from inside generic template) + + Last_Op : Operation := Op_Other; + -- Last operation performed on file, used to avoid unnecessary + -- repositioning between successive read or write operations. + end record; + + function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : access Direct_AFCB); + procedure AFCB_Free (File : access Direct_AFCB); + + procedure Read + (File : in out Direct_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Required overriding of Read, not actually used for Direct_IO + + procedure Write + (File : in out Direct_AFCB; + Item : in Ada.Streams.Stream_Element_Array); + -- Required overriding of Write, not actually used for Direct_IO + + type File_Type is access all Direct_AFCB; + -- File_Type in individual instantiations is derived from this type + + procedure Create + (File : in out File_Type; + Mode : in FCB.File_Mode := FCB.Inout_File; + Name : in String := ""; + Form : in String := ""); + + function End_Of_File (File : in File_Type) return Boolean; + + function Index (File : in File_Type) return Positive_Count; + + procedure Open + (File : in out File_Type; + Mode : in FCB.File_Mode; + Name : in String; + Form : in String := ""); + + procedure Read + (File : in File_Type; + Item : System.Address; + Size : in Interfaces.C_Streams.size_t; + From : in Positive_Count); + + procedure Read + (File : in File_Type; + Item : System.Address; + Size : in Interfaces.C_Streams.size_t); + + procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode); + + procedure Reset (File : in out File_Type); + + procedure Set_Index (File : in File_Type; To : in Positive_Count); + + function Size (File : in File_Type) return Count; + + procedure Write + (File : in File_Type; + Item : System.Address; + Size : in Interfaces.C_Streams.size_t; + Zeroes : System.Storage_Elements.Storage_Array); + -- Note: Zeroes is the buffer of zeroes used to fill out partial records + +end System.Direct_IO; diff --git a/gcc/ada/s-errrep.adb b/gcc/ada/s-errrep.adb new file mode 100644 index 00000000000..7c3450a8561 --- /dev/null +++ b/gcc/ada/s-errrep.adb @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . E R R O R _ R E P O R T I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package must not depend on anything else, since it may be +-- called during elaboration of other packages. + +package body System.Error_Reporting is + + procedure Write (fildes : Integer; buf : System.Address; nbyte : Integer); + pragma Import (C, Write, "write"); + + procedure Prog_Exit (Status : Integer); + pragma No_Return (Prog_Exit); + pragma Import (C, Prog_Exit, "exit"); + + Shutdown_Message : String := "failed run-time assertion : "; + End_Of_Line : String := "" & ASCII.LF; + + -------------- + -- Shutdown -- + -------------- + + function Shutdown (M : in String) return Boolean is + begin + Write (2, Shutdown_Message'Address, Shutdown_Message'Length); + Write (2, M'Address, M'Length); + Write (2, End_Of_Line'Address, End_Of_Line'Length); + + -- This call should never return + + Prog_Exit (1); + + -- Return is just to keep Ada happy (return required) + + return False; + end Shutdown; + +end System.Error_Reporting; diff --git a/gcc/ada/s-errrep.ads b/gcc/ada/s-errrep.ads new file mode 100644 index 00000000000..923b9091274 --- /dev/null +++ b/gcc/ada/s-errrep.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . E R R O R _ R E P O R T I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ -- +-- -- +-- Copyright (C) 1991-1998 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package must not depend on anything else, since it may be +-- called during elaboration of other packages. + +package System.Error_Reporting is + pragma Preelaborate; + + function Shutdown (M : in String) return Boolean; + -- Perform emergency shutdown of the entire program. + -- Msg is an error message to be printed to the console. + -- This is to be used only for nonrecoverable errors. + +end System.Error_Reporting; diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads new file mode 100644 index 00000000000..e277e8c3d1a --- /dev/null +++ b/gcc/ada/s-except.ads @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- 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 contains definitions used for zero cost exception handling. +-- See unit Ada.Exceptions for further details. Note that the reason that +-- we separate out these definitions is to avoid problems with recursion +-- in rtsfind. They must be in a unit which does not require any exception +-- table generation of any kind. + +with Ada.Exceptions; + +with System; +with System.Standard_Library; + +with Unchecked_Conversion; + +package System.Exceptions is + + package SSL renames System.Standard_Library; + package AEX renames Ada.Exceptions; + + -- The following section defines data structures used for zero cost + -- exception handling if System.Parameters.Zero_Cost_Exceptions is + -- set true (i.e. zero cost exceptions are implemented on this target). + + -- The approach is to build tables that describe the PC ranges that + -- are covered by various exception frames. When an exception occurs, + -- these tables are searched to determine the address of the applicable + -- handler for the current exception. + + subtype Handler_Loc is System.Address; + -- Code location representing entry address of a handler. Values of + -- this type are created using the N_Handler_Loc node, and then + -- passed to the Enter_Handler procedure to enter a handler. + + 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. + + -------------------- + -- Handler_Record -- + -------------------- + + -- A Handler record is built for each choice for each exception handler + -- in a frame. + + function To_Exception_Id is + new Unchecked_Conversion (SSL.Exception_Data_Ptr, AEX.Exception_Id); + + Others_Dummy_Exception : aliased SSL.Exception_Data; + Others_Id : constant AEX.Exception_Id := + To_Exception_Id (Others_Dummy_Exception'Access); + -- Dummy exception used to signal others exception + + All_Others_Dummy_Exception : aliased SSL.Exception_Data; + All_Others_Id : constant AEX.Exception_Id := + To_Exception_Id (All_Others_Dummy_Exception'Access); + -- Dummy exception used to signal all others exception (including + -- exceptions not normally handled by others, e.g. Abort_Signal) + + type Handler_Record is record + Lo : Code_Loc; + Hi : Code_Loc; + -- Range of PC values of code covered by this handler record. The + -- handler covers all code addresses that are greater than the Lo + -- value, and less than or equal to the Hi value. + + Id : AEX.Exception_Id; + -- Id of exception being handled, or one of the above special values + + Handler : Handler_Loc; + -- Address of label at start of handler + end record; + + type Handler_Record_Ptr is access all Handler_Record; + type Handler_Record_List is array (Natural range <>) of Handler_Record_Ptr; + + --------------------------- + -- Subprogram_Descriptor -- + --------------------------- + + -- A Subprogram_Descriptor is built for each subprogram through which + -- exceptions may propagate, this includes all Ada subprograms, + -- and also all foreign language imported subprograms. + + subtype Subprogram_Info_Type is System.Address; + -- This type is used to represent a value that is used to unwind stack + -- frames. It references target dependent data that provides sufficient + -- information (e.g. about the location of the return point, use of a + -- frame pointer, save-over-call registers etc) to unwind the machine + -- state to the caller. For some targets, this is simply a pointer to + -- the entry point of the procedure (and the routine to pop the machine + -- state disassembles the code at the entry point to obtain the required + -- information). On other targets, it is a pointer to data created by the + -- backend or assembler to represent the required information. + + No_Info : constant Subprogram_Info_Type := System.Null_Address; + -- This is a special value used to indicate that it is not possible + -- to pop past this frame. This is used at the outer level (e.g. for + -- package elaboration procedures or the main procedure), and for any + -- other foreign language procedure for which propagation is known + -- to be impossible. An exception is considered unhandled if an + -- attempt is made to pop a frame whose Subprogram_Info_Type value + -- is set to No_Info. + + type Subprogram_Descriptor (Num_Handlers : Natural) is record + Code : Code_Loc; + -- This is a code location used to determine which procedure we are + -- in. Most usually it is simply the entry address for the procedure. + -- hA given address is considered to be within the procedure referenced + -- by a Subprogram_Descriptor record if this is the descriptor for + -- which the Code value is as large as possible without exceeding + -- the given value. + + Subprogram_Info : Subprogram_Info_Type; + -- This is a pointer to a target dependent data item that provides + -- sufficient information for unwinding the stack frame of this + -- procedure. A value of No_Info (zero) means that we are the + -- outer level procedure. + + Handler_Records : Handler_Record_List (1 .. Num_Handlers); + -- List of pointers to Handler_Records for this procedure. The array + -- is sorted inside out, i.e. entries for inner frames appear before + -- entries for outer handlers. This ensures that a serial search + -- finds the innermost applicable handler + end record; + + subtype Subprogram_Descriptor_0 is Subprogram_Descriptor (0); + subtype Subprogram_Descriptor_1 is Subprogram_Descriptor (1); + subtype Subprogram_Descriptor_2 is Subprogram_Descriptor (2); + subtype Subprogram_Descriptor_3 is Subprogram_Descriptor (3); + -- Predeclare commonly used subtypes for buildingt he tables + + type Subprogram_Descriptor_Ptr is access all Subprogram_Descriptor; + + type Subprogram_Descriptor_List + is array (Natural range <>) of Subprogram_Descriptor_Ptr; + + type Subprogram_Descriptors_Record (Count : Natural) is record + SDesc : Subprogram_Descriptor_List (1 .. Count); + end record; + + type Subprogram_Descriptors_Ptr is + access all Subprogram_Descriptors_Record; + + -------------------------- + -- Unit Exception_Table -- + -------------------------- + + -- If a unit contains at least one subprogram, then a library level + -- declaration of the form: + + -- Tnn : aliased constant Subprogram_Descriptors := + -- (Count => n, + -- SDesc => + -- (SD1'Unrestricted_Access, + -- SD2'Unrestricted_Access, + -- ... + -- SDn'Unrestricted_Access)); + -- pragma Export (Ada, Tnn, "__gnat_unit_name__SDP"); + + -- is generated where the initializing expression is an array aggregate + -- whose elements are pointers to the generated subprogram descriptors + -- for the units. + + -- Note: the ALI file contains the designation UX in each unit entry + -- if a unit exception table is generated. + + -- The binder generates a list of addresses of pointers to these tables. + +end System.Exceptions; diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb new file mode 100644 index 00000000000..821f1860ccf --- /dev/null +++ b/gcc/ada/s-exctab.adb @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T A B L E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- 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 GNAT.HTable; + +package body System.Exception_Table is + + use System.Standard_Library; + + type HTable_Headers is range 1 .. 37; + + procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr); + function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr; + + function Hash (F : Big_String_Ptr) return HTable_Headers; + function Equal (A, B : Big_String_Ptr) return Boolean; + function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr; + + package Exception_HTable is new GNAT.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Exception_Data, + Elmt_Ptr => Exception_Data_Ptr, + Null_Ptr => null, + Set_Next => Set_HT_Link, + Next => Get_HT_Link, + Key => Big_String_Ptr, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + ----------- + -- Equal -- + ----------- + + function Equal (A, B : Big_String_Ptr) return Boolean is + J : Integer := 1; + + begin + loop + if A (J) /= B (J) then + return False; + + elsif A (J) = ASCII.NUL then + return True; + + else + J := J + 1; + end if; + end loop; + end Equal; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is + begin + return T.HTable_Ptr; + end Get_HT_Link; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr is + begin + return T.Full_Name; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Big_String_Ptr) return HTable_Headers is + type S is mod 2**8; + + Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1); + Tmp : S := 0; + J : Positive; + + begin + J := 1; + loop + if F (J) = ASCII.NUL then + return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size); + else + Tmp := Tmp xor S (Character'Pos (F (J))); + end if; + J := J + 1; + end loop; + end Hash; + + ------------------------ + -- Internal_Exception -- + ------------------------ + + type String_Ptr is access all String; + + function Internal_Exception (X : String) return Exception_Data_Ptr is + Copy : aliased String (X'First .. X'Last + 1); + Res : Exception_Data_Ptr; + Dyn_Copy : String_Ptr; + + begin + Copy (X'Range) := X; + Copy (Copy'Last) := ASCII.NUL; + Res := Exception_HTable.Get (To_Ptr (Copy'Address)); + + -- If unknown exception, create it on the heap. This is a legitimate + -- situation in the distributed case when an exception is defined only + -- in a partition + + if Res = null then + Dyn_Copy := new String'(Copy); + + Res := + new Exception_Data' + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Copy'Length, + Full_Name => To_Ptr (Dyn_Copy.all'Address), + HTable_Ptr => null, + Import_Code => 0); + + Register_Exception (Res); + end if; + + return Res; + end Internal_Exception; + + ------------------------ + -- Register_Exception -- + ------------------------ + + procedure Register_Exception (X : Exception_Data_Ptr) is + begin + Exception_HTable.Set (X); + end Register_Exception; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link + (T : Exception_Data_Ptr; + Next : Exception_Data_Ptr) + is + begin + T.HTable_Ptr := Next; + end Set_HT_Link; + +begin + Register_Exception (Abort_Signal_Def'Access); + Register_Exception (Tasking_Error_Def'Access); + Register_Exception (Storage_Error_Def'Access); + Register_Exception (Program_Error_Def'Access); + Register_Exception (Numeric_Error_Def'Access); + Register_Exception (Constraint_Error_Def'Access); + +end System.Exception_Table; diff --git a/gcc/ada/s-exctab.ads b/gcc/ada/s-exctab.ads new file mode 100644 index 00000000000..e41cfe8ac03 --- /dev/null +++ b/gcc/ada/s-exctab.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T A B L E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1996-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 System.Standard_Library; + +package System.Exception_Table is +pragma Elaborate_Body; + + package SSL renames System.Standard_Library; + + procedure Register_Exception (X : SSL.Exception_Data_Ptr); + pragma Inline (Register_Exception); + -- Register an exception in the hash table mapping + + function Internal_Exception (X : String) return SSL.Exception_Data_Ptr; + -- Given an exception_name X, returns a pointer to the actual internal + -- exception data. + +end System.Exception_Table; diff --git a/gcc/ada/s-exnflt.ads b/gcc/ada/s-exnflt.ads new file mode 100644 index 00000000000..943ed5cbc05 --- /dev/null +++ b/gcc/ada/s-exnflt.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ F L T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Float exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_Flt is +pragma Pure (Exn_Flt); + + function Exn_Float is + new System.Exn_Gen.Exn_Float_Type (Float); + +end System.Exn_Flt; diff --git a/gcc/ada/s-exngen.adb b/gcc/ada/s-exngen.adb new file mode 100644 index 00000000000..1054463c55c --- /dev/null +++ b/gcc/ada/s-exngen.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ G E 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exn_Gen is + + -------------------- + -- Exn_Float_Type -- + -------------------- + + function Exn_Float_Type + (Left : Type_Of_Base; + Right : Integer) + return Type_Of_Base + is + pragma Suppress (Division_Check); + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + + Result : Type_Of_Base := 1.0; + Factor : Type_Of_Base := 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 + -- Division by this factor. + + if Exp >= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + + return Result; + + -- Negative exponent. For a zero base, we should arguably return an + -- infinity of the right sign, but it is not clear that there is + -- proper authorization to do so, so for now raise Constraint_Error??? + + elsif Factor = 0.0 then + raise Constraint_Error; + + -- Here we have a non-zero base and a negative exponent + + else + -- 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 + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + + return 1.0 / Result; + + exception + + when Constraint_Error => + return 0.0; + end; + end if; + end Exn_Float_Type; + + ---------------------- + -- Exn_Integer_Type -- + ---------------------- + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + function Exn_Integer_Type + (Left : Type_Of_Base; + Right : Natural) + return Type_Of_Base + is + pragma Suppress (Division_Check); + pragma Suppress (Overflow_Check); + + Result : Type_Of_Base := 1; + Factor : Type_Of_Base := Left; + Exp : Natural := 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. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + end Exn_Integer_Type; + +end System.Exn_Gen; diff --git a/gcc/ada/s-exngen.ads b/gcc/ada/s-exngen.ads new file mode 100644 index 00000000000..ebd7e2267ae --- /dev/null +++ b/gcc/ada/s-exngen.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ G E N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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 generic functions which are instantiated with +-- predefined integer and real types to generate the runtime exponentiation +-- functions called by expanded code generated by Expand_Op_Expon. This +-- version of the package contains routines that are compiled with overflow +-- checks suppressed, so they are called for exponentiation operations which +-- do not require overflow checking + +package System.Exn_Gen is +pragma Pure (System.Exn_Gen); + + -- Exponentiation for float types (checks off) + + generic + type Type_Of_Base is digits <>; + + function Exn_Float_Type + (Left : Type_Of_Base; + Right : Integer) + return Type_Of_Base; + + -- Exponentiation for signed integer base + + generic + type Type_Of_Base is range <>; + + function Exn_Integer_Type + (Left : Type_Of_Base; + Right : Natural) + return Type_Of_Base; + +end System.Exn_Gen; diff --git a/gcc/ada/s-exnint.ads b/gcc/ada/s-exnint.ads new file mode 100644 index 00000000000..ea67e6dd148 --- /dev/null +++ b/gcc/ada/s-exnint.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1992,1993 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Integer exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_Int is +pragma Pure (Exn_Int); + + function Exn_Integer is + new System.Exn_Gen.Exn_Integer_Type (Integer); + +end System.Exn_Int; diff --git a/gcc/ada/s-exnlfl.ads b/gcc/ada/s-exnlfl.ads new file mode 100644 index 00000000000..50cc8917b94 --- /dev/null +++ b/gcc/ada/s-exnlfl.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L F L T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Float exponentiation (checks on) + +with System.Exn_Gen; + +package System.Exn_LFlt is +pragma Pure (Exn_LFlt); + + function Exn_Long_Float is + new System.Exn_Gen.Exn_Float_Type (Long_Float); + +end System.Exn_LFlt; diff --git a/gcc/ada/s-exnlin.ads b/gcc/ada/s-exnlin.ads new file mode 100644 index 00000000000..76e2e32df6e --- /dev/null +++ b/gcc/ada/s-exnlin.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Integer exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_LInt is +pragma Pure (Exn_LInt); + + function Exn_Long_Integer is + new System.Exn_Gen.Exn_Integer_Type (Long_Integer); + +end System.Exn_LInt; diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads new file mode 100644 index 00000000000..7155b0a9303 --- /dev/null +++ b/gcc/ada/s-exnllf.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L F -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Float exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_LLF is +pragma Pure (Exn_LLF); + + function Exn_Long_Long_Float is + new System.Exn_Gen.Exn_Float_Type (Long_Long_Float); + +end System.Exn_LLF; diff --git a/gcc/ada/s-exnlli.ads b/gcc/ada/s-exnlli.ads new file mode 100644 index 00000000000..7a2456a8e6c --- /dev/null +++ b/gcc/ada/s-exnlli.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1992,1993 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Integer exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_LLI is +pragma Pure (Exn_LLI); + + function Exn_Long_Long_Integer is + new System.Exn_Gen.Exn_Integer_Type (Long_Long_Integer); + +end System.Exn_LLI; diff --git a/gcc/ada/s-exnsfl.ads b/gcc/ada/s-exnsfl.ads new file mode 100644 index 00000000000..1c19ac89804 --- /dev/null +++ b/gcc/ada/s-exnsfl.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ S F L T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Short_Float exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_SFlt is +pragma Pure (Exn_SFlt); + + function Exn_Short_Float is + new System.Exn_Gen.Exn_Float_Type (Short_Float); + +end System.Exn_SFlt; diff --git a/gcc/ada/s-exnsin.ads b/gcc/ada/s-exnsin.ads new file mode 100644 index 00000000000..5623c85ba87 --- /dev/null +++ b/gcc/ada/s-exnsin.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ S I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Short_Integer exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_SInt is +pragma Pure (Exn_SInt); + + function Exn_Short_Integer is + new System.Exn_Gen.Exn_Integer_Type (Short_Integer); + +end System.Exn_SInt; diff --git a/gcc/ada/s-exnssi.ads b/gcc/ada/s-exnssi.ads new file mode 100644 index 00000000000..4ff8f05609e --- /dev/null +++ b/gcc/ada/s-exnssi.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ S S I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Short_Short_Integer exponentiation (checks off) + +with System.Exn_Gen; + +package System.Exn_SSI is +pragma Pure (Exn_SSI); + + function Exn_Short_Short_Integer is + new System.Exn_Gen.Exn_Integer_Type (Short_Short_Integer); + +end System.Exn_SSI; diff --git a/gcc/ada/s-expflt.ads b/gcc/ada/s-expflt.ads new file mode 100644 index 00000000000..4460410f59d --- /dev/null +++ b/gcc/ada/s-expflt.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P F L T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Float exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_Flt is +pragma Pure (Exp_Flt); + + function Exp_Float is new System.Exp_Gen.Exp_Float_Type (Float); + +end System.Exp_Flt; diff --git a/gcc/ada/s-expgen.adb b/gcc/ada/s-expgen.adb new file mode 100644 index 00000000000..4ae3c9830c6 --- /dev/null +++ b/gcc/ada/s-expgen.adb @@ -0,0 +1,183 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ G E N -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exp_Gen is + + -------------------- + -- Exp_Float_Type -- + -------------------- + + function Exp_Float_Type + (Left : Type_Of_Base; + Right : Integer) + return Type_Of_Base + is + Result : Type_Of_Base := 1.0; + Factor : Type_Of_Base := 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. + + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (All_Checks); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Unsuppress (All_Checks); + begin + Factor := Factor * Factor; + end; + end loop; + + return Result; + + -- Now we know that the exponent is negative, check for case of + -- base of 0.0 which always generates a constraint error. + + elsif Factor = 0.0 then + raise Constraint_Error; + + -- Here we have a negative exponent with a non-zero base + + else + + -- 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 essenmtially have is + -- 1.0 / infinity, and the closest model number will be zero. + + begin + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (All_Checks); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Unsuppress (All_Checks); + begin + Factor := Factor * Factor; + end; + end loop; + + declare + pragma Unsuppress (All_Checks); + begin + return 1.0 / Result; + end; + + exception + + when Constraint_Error => + return 0.0; + end; + end if; + end Exp_Float_Type; + + ---------------------- + -- Exp_Integer_Type -- + ---------------------- + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + function Exp_Integer_Type + (Left : Type_Of_Base; + Right : Natural) + return Type_Of_Base + is + Result : Type_Of_Base := 1; + Factor : Type_Of_Base := Left; + Exp : Natural := 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. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (All_Checks); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Unsuppress (All_Checks); + begin + Factor := Factor * Factor; + end; + end loop; + end if; + + return Result; + end Exp_Integer_Type; + +end System.Exp_Gen; diff --git a/gcc/ada/s-expgen.ads b/gcc/ada/s-expgen.ads new file mode 100644 index 00000000000..05b72a60d14 --- /dev/null +++ b/gcc/ada/s-expgen.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ G E N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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 generic functions which are instantiated with +-- predefined integer and real types to generate the runtime exponentiation +-- functions called by expanded code generated by Expand_Op_Expon. This +-- version of the package contains routines that are compiled with overflow +-- checks enabled, so they are called for exponentiation operations which +-- require overflow checking + +package System.Exp_Gen is +pragma Pure (System.Exp_Gen); + + -- Exponentiation for float types (checks on) + + generic + type Type_Of_Base is digits <>; + + function Exp_Float_Type + (Left : Type_Of_Base; + Right : Integer) + return Type_Of_Base; + + -- Exponentiation for signed integer types (checks on) + + generic + type Type_Of_Base is range <>; + + function Exp_Integer_Type + (Left : Type_Of_Base; + Right : Natural) + return Type_Of_Base; + +end System.Exp_Gen; diff --git a/gcc/ada/s-expint.ads b/gcc/ada/s-expint.ads new file mode 100644 index 00000000000..7a23fce46f3 --- /dev/null +++ b/gcc/ada/s-expint.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992,1993 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Integer exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_Int is +pragma Pure (Exp_Int); + + function Exp_Integer is new System.Exp_Gen.Exp_Integer_Type (Integer); + +end System.Exp_Int; diff --git a/gcc/ada/s-explfl.ads b/gcc/ada/s-explfl.ads new file mode 100644 index 00000000000..34ec71b61d1 --- /dev/null +++ b/gcc/ada/s-explfl.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L F L T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Float exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_LFlt is +pragma Pure (Exp_LFlt); + + function Exp_Long_Float is + new System.Exp_Gen.Exp_Float_Type (Long_Float); + +end System.Exp_LFlt; diff --git a/gcc/ada/s-explin.ads b/gcc/ada/s-explin.ads new file mode 100644 index 00000000000..1c4b5247ca2 --- /dev/null +++ b/gcc/ada/s-explin.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Integer exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_LInt is +pragma Pure (Exp_LInt); + + function Exp_Long_Integer is + new System.Exp_Gen.Exp_Integer_Type (Long_Integer); + +end System.Exp_LInt; diff --git a/gcc/ada/s-expllf.ads b/gcc/ada/s-expllf.ads new file mode 100644 index 00000000000..253a9577f10 --- /dev/null +++ b/gcc/ada/s-expllf.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L F -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Float exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_LLF is +pragma Pure (Exp_LLF); + + function Exp_Long_Long_Float is + new System.Exp_Gen.Exp_Float_Type (Long_Long_Float); + +end System.Exp_LLF; diff --git a/gcc/ada/s-explli.ads b/gcc/ada/s-explli.ads new file mode 100644 index 00000000000..beb545b03b1 --- /dev/null +++ b/gcc/ada/s-explli.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- Copyright (C) 1992,1993 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Integer exponentiation + +with System.Exp_Gen; + +package System.Exp_LLI is +pragma Pure (Exp_LLI); + + function Exp_Long_Long_Integer is + new System.Exp_Gen.Exp_Integer_Type (Long_Long_Integer); + +end System.Exp_LLI; diff --git a/gcc/ada/s-expllu.adb b/gcc/ada/s-expllu.adb new file mode 100644 index 00000000000..39f3144a3a1 --- /dev/null +++ b/gcc/ada/s-expllu.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . X P _ B M L -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; + +package body System.Exp_LLU is + + ---------------------------- + -- Exp_Long_Long_Unsigned -- + ---------------------------- + + function Exp_Long_Long_Unsigned + (Left : Long_Long_Unsigned; + Right : Natural) + return Long_Long_Unsigned + is + Result : Long_Long_Unsigned := 1; + Factor : Long_Long_Unsigned := Left; + Exp : Natural := 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. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + + end Exp_Long_Long_Unsigned; + +end System.Exp_LLU; diff --git a/gcc/ada/s-expllu.ads b/gcc/ada/s-expllu.ads new file mode 100644 index 00000000000..b75420920f8 --- /dev/null +++ b/gcc/ada/s-expllu.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L U -- +-- -- +-- 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 procedure performs exponentiation of unsigned types (with binary +-- modulus values exceeding that of Unsigned_Types.Unsigned). The result +-- is always full width, the caller must do a masking operation if the +-- modulus is less than 2 ** (Long_Long_Unsigned'Size). + +with System.Unsigned_Types; + +package System.Exp_LLU is +pragma Pure (Exp_LLU); + + function Exp_Long_Long_Unsigned + (Left : System.Unsigned_Types.Long_Long_Unsigned; + Right : Natural) + return System.Unsigned_Types.Long_Long_Unsigned; + +end System.Exp_LLU; diff --git a/gcc/ada/s-expmod.adb b/gcc/ada/s-expmod.adb new file mode 100644 index 00000000000..a87002bcbf1 --- /dev/null +++ b/gcc/ada/s-expmod.adb @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ M O D -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exp_Mod is + + ----------------- + -- Exp_Modular -- + ----------------- + + function Exp_Modular + (Left : Integer; + Modulus : Integer; + Right : Natural) + return Integer + is + Result : Integer := 1; + Factor : Integer := Left; + Exp : Natural := Right; + + function Mult (X, Y : Integer) return Integer; + pragma Inline (Mult); + -- Modular multiplication. Note that we can't take advantage of the + -- compiler's circuit, because the modulus is not known statically. + + function Mult (X, Y : Integer) return Integer is + begin + return Integer + (Long_Long_Integer (X) * Long_Long_Integer (Y) + mod Long_Long_Integer (Modulus)); + end Mult; + + -- Start of processing for Exp_Modular + + 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. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Mult (Result, Factor); + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Mult (Factor, Factor); + end loop; + end if; + + return Result; + + end Exp_Modular; + +end System.Exp_Mod; diff --git a/gcc/ada/s-expmod.ads b/gcc/ada/s-expmod.ads new file mode 100644 index 00000000000..79f6400a3a6 --- /dev/null +++ b/gcc/ada/s-expmod.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ M O D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This procedure performs exponentiation of a modular type with non-binary +-- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit +-- accounting for the modulus value which is passed as the second argument. + +package System.Exp_Mod is +pragma Pure (Exp_Mod); + + function Exp_Modular + (Left : Integer; + Modulus : Integer; + Right : Natural) + return Integer; + +end System.Exp_Mod; diff --git a/gcc/ada/s-expsfl.ads b/gcc/ada/s-expsfl.ads new file mode 100644 index 00000000000..cfabd1650a6 --- /dev/null +++ b/gcc/ada/s-expsfl.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ S F L T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Short_Float exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_SFlt is +pragma Pure (Exp_SFlt); + + function Exp_Short_Float is + new System.Exp_Gen.Exp_Float_Type (Short_Float); + +end System.Exp_SFlt; diff --git a/gcc/ada/s-expsin.ads b/gcc/ada/s-expsin.ads new file mode 100644 index 00000000000..c5bc2c3054b --- /dev/null +++ b/gcc/ada/s-expsin.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ S I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Short_Integer exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_SInt is +pragma Pure (Exp_SInt); + + function Exp_Short_Integer is + new System.Exp_Gen.Exp_Integer_Type (Short_Integer); + +end System.Exp_SInt; diff --git a/gcc/ada/s-expssi.ads b/gcc/ada/s-expssi.ads new file mode 100644 index 00000000000..802412d56c6 --- /dev/null +++ b/gcc/ada/s-expssi.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P S S I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Short_Short_Integer exponentiation (checks on) + +with System.Exp_Gen; + +package System.Exp_SSI is +pragma Pure (Exp_SSI); + + function Exp_Short_Short_Integer is + new System.Exp_Gen.Exp_Integer_Type (Short_Short_Integer); + +end System.Exp_SSI; diff --git a/gcc/ada/s-expuns.adb b/gcc/ada/s-expuns.adb new file mode 100644 index 00000000000..a02a6994cb4 --- /dev/null +++ b/gcc/ada/s-expuns.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ U N S -- +-- -- +-- B o d y -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Exp_Uns is + + ------------------ + -- Exp_Unsigned -- + ------------------ + + function Exp_Unsigned + (Left : Unsigned; + Right : Natural) + return Unsigned + is + Result : Unsigned := 1; + Factor : Unsigned := Left; + Exp : Natural := 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. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + end Exp_Unsigned; + +end System.Exp_Uns; diff --git a/gcc/ada/s-expuns.ads b/gcc/ada/s-expuns.ads new file mode 100644 index 00000000000..9d4989bf16b --- /dev/null +++ b/gcc/ada/s-expuns.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ U N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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 procedure performs exponentiation of unsigned types (with binary +-- modulus values up to and including that of Unsigned_Types.Unsigned). +-- The result is always full width, the caller must do a masking operation +-- the modulus is less than 2 ** (Unsigned'Size). + +with System.Unsigned_Types; + +package System.Exp_Uns is +pragma Pure (Exp_Uns); + + function Exp_Unsigned + (Left : System.Unsigned_Types.Unsigned; + Right : Natural) + return System.Unsigned_Types.Unsigned; + +end System.Exp_Uns; diff --git a/gcc/ada/s-fatflt.ads b/gcc/ada/s-fatflt.ads new file mode 100644 index 00000000000..b27d4b2b839 --- /dev/null +++ b/gcc/ada/s-fatflt.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ F L T -- +-- -- +-- 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 contains an instantiation of the floating-point attribute +-- runtime routines for the type Float. + +with System.Fat_Gen; + +package System.Fat_Flt is +pragma Pure (Fat_Flt); + + -- Note the only entity from this package that is acccessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Fat_Float is new System.Fat_Gen (Float); + +end System.Fat_Flt; diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb new file mode 100644 index 00000000000..7fb8160c691 --- /dev/null +++ b/gcc/ada/s-fatgen.adb @@ -0,0 +1,836 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ G E N -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation here is portable to any IEEE implementation. It does +-- not handle non-binary radix, and also assumes that model numbers and +-- machine numbers are basically identical, which is not true of all possible +-- floating-point implementations. On a non-IEEE machine, this body must be +-- specialized appropriately, or better still, its generic instantiations +-- should be replaced by efficient machine-specific code. + +with Ada.Unchecked_Conversion; use Ada; +with System; +package body System.Fat_Gen is + + Float_Radix : constant T := T (T'Machine_Radix); + Float_Radix_Inv : constant T := 1.0 / Float_Radix; + Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1); + + pragma Assert (T'Machine_Radix = 2); + -- This version does not handle radix 16 + + -- Constants for Decompose and Scaling + + Rad : constant T := T (T'Machine_Radix); + Invrad : constant T := 1.0 / Rad; + + subtype Expbits is Integer range 0 .. 6; + -- 2 ** (2 ** 7) might overflow. how big can radix-16 exponents get? + + Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); + + R_Power : constant array (Expbits) of T := + (Rad ** 1, + Rad ** 2, + Rad ** 4, + Rad ** 8, + Rad ** 16, + Rad ** 32, + Rad ** 64); + + R_Neg_Power : constant array (Expbits) of T := + (Invrad ** 1, + Invrad ** 2, + Invrad ** 4, + Invrad ** 8, + Invrad ** 16, + Invrad ** 32, + Invrad ** 64); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Decompose (XX : T; Frac : out T; Expo : out UI); + -- Decomposes a floating-point number into fraction and exponent parts + + function Gradual_Scaling (Adjustment : UI) return T; + -- Like Scaling with a first argument of 1.0, but returns the smallest + -- denormal rather than zero when the adjustment is smaller than + -- Machine_Emin. Used for Succ and Pred. + + -------------- + -- Adjacent -- + -------------- + + function Adjacent (X, Towards : T) return T is + begin + if Towards = X then + return X; + + elsif Towards > X then + return Succ (X); + + else + return Pred (X); + end if; + end Adjacent; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (X : T) return T is + XT : constant T := Truncation (X); + + begin + if X <= 0.0 then + return XT; + + elsif X = XT then + return X; + + else + return XT + 1.0; + end if; + end Ceiling; + + ------------- + -- Compose -- + ------------- + + function Compose (Fraction : T; Exponent : UI) return T is + Arg_Frac : T; + Arg_Exp : UI; + + begin + Decompose (Fraction, Arg_Frac, Arg_Exp); + return Scaling (Arg_Frac, Exponent); + end Compose; + + --------------- + -- Copy_Sign -- + --------------- + + function Copy_Sign (Value, Sign : T) return T is + Result : T; + + function Is_Negative (V : T) return Boolean; + pragma Import (Intrinsic, Is_Negative); + + begin + Result := abs Value; + + if Is_Negative (Sign) then + return -Result; + else + return Result; + end if; + end Copy_Sign; + + --------------- + -- Decompose -- + --------------- + + procedure Decompose (XX : T; Frac : out T; Expo : out UI) is + X : T := T'Machine (XX); + + begin + if X = 0.0 then + Frac := X; + Expo := 0; + + -- More useful would be defining Expo to be T'Machine_Emin - 1 or + -- T'Machine_Emin - T'Machine_Mantissa, which would preserve + -- monotonicity of the exponent fuction ??? + + -- Check for infinities, transfinites, whatnot. + + elsif X > T'Safe_Last then + Frac := Invrad; + Expo := T'Machine_Emax + 1; + + elsif X < T'Safe_First then + Frac := -Invrad; + Expo := T'Machine_Emax + 2; -- how many extra negative values? + + else + -- Case of nonzero finite x. Essentially, we just multiply + -- by Rad ** (+-2**N) to reduce the range. + + declare + Ax : T := abs X; + Ex : UI := 0; + + -- Ax * Rad ** Ex is invariant. + + begin + if Ax >= 1.0 then + while Ax >= R_Power (Expbits'Last) loop + Ax := Ax * R_Neg_Power (Expbits'Last); + Ex := Ex + Log_Power (Expbits'Last); + end loop; + + -- Ax < Rad ** 64 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ax >= R_Power (N) then + Ax := Ax * R_Neg_Power (N); + Ex := Ex + Log_Power (N); + end if; + + -- Ax < R_Power (N) + end loop; + + -- 1 <= Ax < Rad + + Ax := Ax * Invrad; + Ex := Ex + 1; + + else + -- 0 < ax < 1 + + while Ax < R_Neg_Power (Expbits'Last) loop + Ax := Ax * R_Power (Expbits'Last); + Ex := Ex - Log_Power (Expbits'Last); + end loop; + + -- Rad ** -64 <= Ax < 1 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ax < R_Neg_Power (N) then + Ax := Ax * R_Power (N); + Ex := Ex - Log_Power (N); + end if; + + -- R_Neg_Power (N) <= Ax < 1 + end loop; + end if; + + if X > 0.0 then + Frac := Ax; + else + Frac := -Ax; + end if; + + Expo := Ex; + end; + end if; + end Decompose; + + -------------- + -- Exponent -- + -------------- + + function Exponent (X : T) return UI is + X_Frac : T; + X_Exp : UI; + + begin + Decompose (X, X_Frac, X_Exp); + return X_Exp; + end Exponent; + + ----------- + -- Floor -- + ----------- + + function Floor (X : T) return T is + XT : constant T := Truncation (X); + + begin + if X >= 0.0 then + return XT; + + elsif XT = X then + return X; + + else + return XT - 1.0; + end if; + end Floor; + + -------------- + -- Fraction -- + -------------- + + function Fraction (X : T) return T is + X_Frac : T; + X_Exp : UI; + + begin + Decompose (X, X_Frac, X_Exp); + return X_Frac; + end Fraction; + + --------------------- + -- Gradual_Scaling -- + --------------------- + + function Gradual_Scaling (Adjustment : UI) return T is + Y : T; + Y1 : T; + Ex : UI := Adjustment; + + begin + if Adjustment < T'Machine_Emin then + Y := 2.0 ** T'Machine_Emin; + Y1 := Y; + Ex := Ex - T'Machine_Emin; + + while Ex <= 0 loop + Y := T'Machine (Y / 2.0); + + if Y = 0.0 then + return Y1; + end if; + + Ex := Ex + 1; + Y1 := Y; + end loop; + + return Y1; + + else + return Scaling (1.0, Adjustment); + end if; + end Gradual_Scaling; + + ------------------ + -- Leading_Part -- + ------------------ + + function Leading_Part (X : T; Radix_Digits : UI) return T is + L : UI; + Y, Z : T; + + begin + if Radix_Digits >= T'Machine_Mantissa then + return X; + + else + L := Exponent (X) - Radix_Digits; + Y := Truncation (Scaling (X, -L)); + Z := Scaling (Y, L); + return Z; + end if; + + end Leading_Part; + + ------------- + -- Machine -- + ------------- + + -- The trick with Machine is to force the compiler to store the result + -- in memory so that we do not have extra precision used. The compiler + -- is clever, so we have to outwit its possible optimizations! We do + -- this by using an intermediate pragma Volatile location. + + function Machine (X : T) return T is + Temp : T; + pragma Volatile (Temp); + + begin + Temp := X; + return Temp; + end Machine; + + ----------- + -- Model -- + ----------- + + -- We treat Model as identical to Machine. This is true of IEEE and other + -- nice floating-point systems, but not necessarily true of all systems. + + function Model (X : T) return T is + begin + return Machine (X); + end Model; + + ---------- + -- Pred -- + ---------- + + -- Subtract from the given number a number equivalent to the value of its + -- least significant bit. Given that the most significant bit represents + -- a value of 1.0 * radix ** (exp - 1), the value we want is obtained by + -- shifting this by (mantissa-1) bits to the right, i.e. decreasing the + -- exponent by that amount. + + -- Zero has to be treated specially, since its exponent is zero + + function Pred (X : T) return T is + X_Frac : T; + X_Exp : UI; + + begin + if X = 0.0 then + return -Succ (X); + + else + Decompose (X, X_Frac, X_Exp); + + -- A special case, if the number we had was a positive power of + -- two, then we want to subtract half of what we would otherwise + -- subtract, since the exponent is going to be reduced. + + if X_Frac = 0.5 and then X > 0.0 then + return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); + + -- Otherwise the exponent stays the same + + else + return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa); + end if; + end if; + end Pred; + + --------------- + -- Remainder -- + --------------- + + function Remainder (X, Y : T) return T is + A : T; + B : T; + Arg : T; + P : T; + Arg_Frac : T; + P_Frac : T; + Sign_X : T; + IEEE_Rem : T; + Arg_Exp : UI; + P_Exp : UI; + K : UI; + P_Even : Boolean; + + begin + if X > 0.0 then + Sign_X := 1.0; + Arg := X; + else + Sign_X := -1.0; + Arg := -X; + end if; + + P := abs Y; + + if Arg < P then + P_Even := True; + IEEE_Rem := Arg; + P_Exp := Exponent (P); + + else + Decompose (Arg, Arg_Frac, Arg_Exp); + Decompose (P, P_Frac, P_Exp); + + P := Compose (P_Frac, Arg_Exp); + K := Arg_Exp - P_Exp; + P_Even := True; + IEEE_Rem := Arg; + + for Cnt in reverse 0 .. K loop + if IEEE_Rem >= P then + P_Even := False; + IEEE_Rem := IEEE_Rem - P; + else + P_Even := True; + end if; + + P := P * 0.5; + end loop; + end if; + + -- That completes the calculation of modulus remainder. The final + -- step is get the IEEE remainder. Here we need to compare Rem with + -- (abs Y) / 2. We must be careful of unrepresentable Y/2 value + -- caused by subnormal numbers + + if P_Exp >= 0 then + A := IEEE_Rem; + B := abs Y * 0.5; + + else + A := IEEE_Rem * 2.0; + B := abs Y; + end if; + + if A > B or else (A = B and then not P_Even) then + IEEE_Rem := IEEE_Rem - abs Y; + end if; + + return Sign_X * IEEE_Rem; + + end Remainder; + + -------------- + -- Rounding -- + -------------- + + function Rounding (X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (abs X); + Tail := abs X - Result; + + if Tail >= 0.5 then + Result := Result + 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + + end Rounding; + + ------------- + -- Scaling -- + ------------- + + -- Return x * rad ** adjustment quickly, + -- or quietly underflow to zero, or overflow naturally. + + function Scaling (X : T; Adjustment : UI) return T is + begin + if X = 0.0 or else Adjustment = 0 then + return X; + end if; + + -- Nonzero x. essentially, just multiply repeatedly by Rad ** (+-2**n). + + declare + Y : T := X; + Ex : UI := Adjustment; + + -- Y * Rad ** Ex is invariant + + begin + if Ex < 0 then + while Ex <= -Log_Power (Expbits'Last) loop + Y := Y * R_Neg_Power (Expbits'Last); + Ex := Ex + Log_Power (Expbits'Last); + end loop; + + -- -64 < Ex <= 0 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ex <= -Log_Power (N) then + Y := Y * R_Neg_Power (N); + Ex := Ex + Log_Power (N); + end if; + + -- -Log_Power (N) < Ex <= 0 + end loop; + + -- Ex = 0 + + else + -- Ex >= 0 + + while Ex >= Log_Power (Expbits'Last) loop + Y := Y * R_Power (Expbits'Last); + Ex := Ex - Log_Power (Expbits'Last); + end loop; + + -- 0 <= Ex < 64 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ex >= Log_Power (N) then + Y := Y * R_Power (N); + Ex := Ex - Log_Power (N); + end if; + + -- 0 <= Ex < Log_Power (N) + end loop; + + -- Ex = 0 + end if; + return Y; + end; + end Scaling; + + ---------- + -- Succ -- + ---------- + + -- Similar computation to that of Pred: find value of least significant + -- bit of given number, and add. Zero has to be treated specially since + -- the exponent can be zero, and also we want the smallest denormal if + -- denormals are supported. + + function Succ (X : T) return T is + X_Frac : T; + X_Exp : UI; + X1, X2 : T; + + begin + if X = 0.0 then + X1 := 2.0 ** T'Machine_Emin; + + -- Following loop generates smallest denormal + + loop + X2 := T'Machine (X1 / 2.0); + exit when X2 = 0.0; + X1 := X2; + end loop; + + return X1; + + else + Decompose (X, X_Frac, X_Exp); + + -- A special case, if the number we had was a negative power of + -- two, then we want to add half of what we would otherwise add, + -- since the exponent is going to be reduced. + + if X_Frac = 0.5 and then X < 0.0 then + return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); + + -- Otherwise the exponent stays the same + + else + return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa); + end if; + end if; + end Succ; + + ---------------- + -- Truncation -- + ---------------- + + -- The basic approach is to compute + + -- T'Machine (RM1 + N) - RM1. + + -- where N >= 0.0 and RM1 = radix ** (mantissa - 1) + + -- This works provided that the intermediate result (RM1 + N) does not + -- have extra precision (which is why we call Machine). When we compute + -- RM1 + N, the exponent of N will be normalized and the mantissa shifted + -- shifted appropriately so the lower order bits, which cannot contribute + -- to the integer part of N, fall off on the right. When we subtract RM1 + -- again, the significant bits of N are shifted to the left, and what we + -- have is an integer, because only the first e bits are different from + -- zero (assuming binary radix here). + + function Truncation (X : T) return T is + Result : T; + + begin + Result := abs X; + + if Result >= Radix_To_M_Minus_1 then + return Machine (X); + + else + Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1; + + if Result > abs X then + Result := Result - 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end if; + + end Truncation; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + function Unbiased_Rounding (X : T) return T is + Abs_X : constant T := abs X; + Result : T; + Tail : T; + + begin + Result := Truncation (Abs_X); + Tail := Abs_X - Result; + + if Tail > 0.5 then + Result := Result + 1.0; + + elsif Tail = 0.5 then + Result := 2.0 * Truncation ((Result / 2.0) + 0.5); + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + + end Unbiased_Rounding; + + ----------- + -- Valid -- + ----------- + + function Valid (X : access T) return Boolean is + + IEEE_Emin : constant Integer := T'Machine_Emin - 1; + IEEE_Emax : constant Integer := T'Machine_Emax - 1; + + IEEE_Bias : constant Integer := -(IEEE_Emin - 1); + + subtype IEEE_Exponent_Range is + Integer range IEEE_Emin - 1 .. IEEE_Emax + 1; + + -- The implementation of this floating point attribute uses + -- a representation type Float_Rep that allows direct access to + -- the exponent and mantissa parts of a floating point number. + + -- The Float_Rep type is an array of Float_Word elements. This + -- representation is chosen to make it possible to size the + -- type based on a generic parameter. + + -- The following conditions must be met for all possible + -- instantiations of the attributes package: + + -- - T'Size is an integral multiple of Float_Word'Size + + -- - The exponent and sign are completely contained in a single + -- component of Float_Rep, named Most_Significant_Word (MSW). + + -- - The sign occupies the most significant bit of the MSW + -- and the exponent is in the following bits. + -- Unused bits (if any) are in the least significant part. + + type Float_Word is mod 2**32; + type Rep_Index is range 0 .. 7; + + Rep_Last : constant Rep_Index := (T'Size - 1) / Float_Word'Size; + + type Float_Rep is array (Rep_Index range 0 .. Rep_Last) of Float_Word; + + Most_Significant_Word : constant Rep_Index := + Rep_Last * Standard'Default_Bit_Order; + -- Finding the location of the Exponent_Word is a bit tricky. + -- In general we assume Word_Order = Bit_Order. + -- This expression needs to be refined for VMS. + + Exponent_Factor : constant Float_Word := + 2**(Float_Word'Size - 1) / + Float_Word (IEEE_Emax - IEEE_Emin + 3) * + Boolean'Pos (T'Size /= 96) + + Boolean'Pos (T'Size = 96); + -- Factor that the extracted exponent needs to be divided by + -- to be in range 0 .. IEEE_Emax - IEEE_Emin + 2. + -- Special kludge: Exponent_Factor is 0 for x86 double extended + -- as GCC adds 16 unused bits to the type. + + Exponent_Mask : constant Float_Word := + Float_Word (IEEE_Emax - IEEE_Emin + 2) * + Exponent_Factor; + -- Value needed to mask out the exponent field. + -- This assumes that the range IEEE_Emin - 1 .. IEEE_Emax + 1 + -- contains 2**N values, for some N in Natural. + + function To_Float is new Unchecked_Conversion (Float_Rep, T); + + type Float_Access is access all T; + function To_Address is + new Unchecked_Conversion (Float_Access, System.Address); + + XA : constant System.Address := To_Address (Float_Access (X)); + + R : Float_Rep; + pragma Import (Ada, R); + for R'Address use XA; + -- R is a view of the input floating-point parameter. Note that we + -- must avoid copying the actual bits of this parameter in float + -- form (since it may be a signalling NaN. + + E : constant IEEE_Exponent_Range := + Integer ((R (Most_Significant_Word) and Exponent_Mask) / + Exponent_Factor) + - IEEE_Bias; + -- Mask/Shift T to only get bits from the exponent + -- Then convert biased value to integer value. + + SR : Float_Rep; + -- Float_Rep representation of significant of X.all + + begin + if T'Denorm then + + -- All denormalized numbers are valid, so only invalid numbers + -- are overflows and NaN's, both with exponent = Emax + 1. + + return E /= IEEE_Emax + 1; + + end if; + + -- All denormalized numbers except 0.0 are invalid + + -- Set exponent of X to zero, so we end up with the significand, which + -- definitely is a valid number and can be converted back to a float. + + SR := R; + SR (Most_Significant_Word) := + (SR (Most_Significant_Word) + and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor; + + return (E in IEEE_Emin .. IEEE_Emax) or else + ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0); + end Valid; + +end System.Fat_Gen; diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads new file mode 100644 index 00000000000..0ad0d682216 --- /dev/null +++ b/gcc/ada/s-fatgen.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ G E N -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This generic package provides a target independent implementation of the +-- floating-point attributes that denote functions. The implementations here +-- are portable, but very slow. The runtime contains a set of instantiations +-- of this package for all predefined floating-point types, and these should +-- be replaced by efficient assembly language code where possible. + +generic + type T is digits <>; + +package System.Fat_Gen is +pragma Pure (Fat_Gen); + + subtype UI is Integer; + -- The runtime representation of universal integer for the purposes of + -- this package is integer. The expander generates conversions for the + -- actual type used. For functions returning universal integer, there + -- is no problem, since the result always is in range of integer. For + -- input arguments, the expander has to do some special casing to deal + -- with the (very annoying!) cases of out of range values. If we used + -- Long_Long_Integer to represent universal, then there would be no + -- problem, but the resulting inefficiency would be annoying. + + function Adjacent (X, Towards : T) return T; + + function Ceiling (X : T) return T; + + function Compose (Fraction : T; Exponent : UI) return T; + + function Copy_Sign (Value, Sign : T) return T; + + function Exponent (X : T) return UI; + + function Floor (X : T) return T; + + function Fraction (X : T) return T; + + function Leading_Part (X : T; Radix_Digits : UI) return T; + + function Machine (X : T) return T; + + function Model (X : T) return T; + + function Pred (X : T) return T; + + function Remainder (X, Y : T) return T; + + function Rounding (X : T) return T; + + function Scaling (X : T; Adjustment : UI) return T; + + function Succ (X : T) return T; + + function Truncation (X : T) return T; + + function Unbiased_Rounding (X : T) return T; + + function Valid (X : access T) return Boolean; + -- The argument must be passed by reference here, as T may be + -- an abnormal value that can be passed in a floating point register. + +private + pragma Inline (Machine); + pragma Inline (Model); + pragma Inline_Always (Valid); + +end System.Fat_Gen; diff --git a/gcc/ada/s-fatlfl.ads b/gcc/ada/s-fatlfl.ads new file mode 100644 index 00000000000..a16a26fbe91 --- /dev/null +++ b/gcc/ada/s-fatlfl.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ L F L T -- +-- -- +-- 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 contains an instantiation of the floating-point attribute +-- runtime routines for the type Long_Float. + +with System.Fat_Gen; + +package System.Fat_LFlt is +pragma Pure (Fat_LFlt); + + -- Note the only entity from this package that is acccessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Fat_Long_Float is new System.Fat_Gen (Long_Float); + +end System.Fat_LFlt; diff --git a/gcc/ada/s-fatllf.ads b/gcc/ada/s-fatllf.ads new file mode 100644 index 00000000000..3d4953dff46 --- /dev/null +++ b/gcc/ada/s-fatllf.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ L L F -- +-- -- +-- 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 contains an instantiation of the floating-point attribute +-- runtime routines for the type Long_Long_Float. + +with System.Fat_Gen; + +package System.Fat_LLF is +pragma Pure (Fat_LLF); + + -- Note the only entity from this package that is acccessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Fat_Long_Long_Float is new System.Fat_Gen (Long_Long_Float); + +end System.Fat_LLF; diff --git a/gcc/ada/s-fatsfl.ads b/gcc/ada/s-fatsfl.ads new file mode 100644 index 00000000000..bc17fbd6647 --- /dev/null +++ b/gcc/ada/s-fatsfl.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ S F L T -- +-- -- +-- 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 contains an instantiation of the floating-point attribute +-- runtime routines for the type Short_Float. + +with System.Fat_Gen; + +package System.Fat_SFlt is +pragma Pure (Fat_SFlt); + + -- Note the only entity from this package that is acccessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Fat_Short_Float is new System.Fat_Gen (Short_Float); + +end System.Fat_SFlt; diff --git a/gcc/ada/s-ficobl.ads b/gcc/ada/s-ficobl.ads new file mode 100644 index 00000000000..61451f4c538 --- /dev/null +++ b/gcc/ada/s-ficobl.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ C O N T R O L _ B L O C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- 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 contains the declaration of the basic file control block +-- shared between Text_IO, Sequential_IO, Direct_IO and Streams.Stream_IO. +-- The actual control blocks are derived from this block by extension. The +-- control block is itself derived from Ada.Streams.Root_Stream_Type which +-- facilitates implementation of Stream_IO.Stream and Text_Streams.Stream. + +with Ada.Streams; +with Interfaces.C_Streams; + +package System.File_Control_Block is + + ----------------------------- + -- Ada File Control Block -- + ----------------------------- + + -- The Ada file control block is an abstract extension of the root + -- stream type. This allows a file to be treated directly as a stream + -- for the purposes of Stream_IO, or stream operations on a text file. + -- The individual I/O packages extend this type with package specific + -- fields to create the concrete types to which the routines in this + -- package can be applied. + + -- The type File_Type in the individual packages is an access to the + -- extended file control block. The value is null if the file is not + -- open, and a pointer to the control block if the file is open. + + type Pstring is access all String; + -- Used to hold name and form strings + + type File_Mode is (In_File, Inout_File, Out_File, Append_File); + -- File mode (union of file modes permitted by individual packages, + -- the types File_Mode in the individual packages are declared to + -- allow easy conversion to and from this general type. + + type Shared_Status_Type is (Yes, No, None); + -- This type is used to define the sharing status of a file. The default + -- setting of None is used if no "shared=xxx" appears in the form string + -- when a file is created or opened. For a file with Shared_Status set to + -- None, Use_Error will be raised if any other file is opened or created + -- with the same full name. Yes/No are set in response to the presence + -- of "shared=yes" or "shared=no" in the form string. In either case it + -- is permissible to have multiple files opened with the same full name. + -- All files opened simultaneously with "shared=yes" will share the same + -- stream with the semantics specified in the RM for file sharing. All + -- files opened with "shared=no" will have their own stream. + + type AFCB; + type AFCB_Ptr is access all AFCB'Class; + + type AFCB is abstract new Ada.Streams.Root_Stream_Type with record + + Stream : Interfaces.C_Streams.FILEs; + -- The file descriptor + + Name : Pstring; + -- A pointer to the file name. The file name is null for temporary + -- files, and also for standard files (stdin, stdout, stderr). The + -- name is always null-terminated if it is non-null. + + Form : Pstring; + -- A pointer to the form string. This is the string used in the + -- fopen call, and must be supplied by the caller (there are no + -- defaults at this level). The string is always null-terminated. + + Mode : File_Mode; + -- The file mode. No checks are made that the mode is consistent + -- with the form used to fopen the file. + + Is_Regular_File : Boolean; + -- A flag indicating if the file is a regular file + + Is_Temporary_File : Boolean; + -- A flag set only for temporary files (i.e. files created using the + -- Create function with a null name parameter, using tmpfile). This + -- is currently not used since temporary files are deleted by the + -- operating system, but it is set properly in case some systems + -- need this information in the future. + + Is_System_File : Boolean; + -- A flag set only for system files (stdin, stdout, stderr) + + Is_Text_File : Boolean; + -- A flag set if the file was opened in text mode + + Shared_Status : Shared_Status_Type; + -- Indicates sharing status of file, see description of type above + + Access_Method : Character; + -- Set to 'Q', 'S', 'T, 'D' for Sequential_IO, Stream_IO, Text_IO + -- Direct_IO file (used to validate file sharing request). + + Next : AFCB_Ptr; + Prev : AFCB_Ptr; + -- All open files are kept on a doubly linked chain, with these + -- pointers used to maintain the next and previous pointers. + + end record; + + ---------------------------------- + -- Primitive Operations of AFCB -- + ---------------------------------- + + -- Note that we inherit the abstract operations Read and Write from + -- the base type. These must be overridden by the individual file + -- access methods to provide Stream Read/Write access. + + function AFCB_Allocate (Control_Block : AFCB) return AFCB_Ptr is abstract; + -- Given a control block, allocate space for a control block of the same + -- type on the heap, and return the pointer to this allocated block. Note + -- that the argument Control_Block is not used other than as the argument + -- that controls which version of AFCB_Allocate is called. + + procedure AFCB_Close (File : access AFCB) is abstract; + -- Performs any specialized close actions on a file before the file is + -- actually closed at the system level. This is called by Close, and + -- the reason we need the primitive operation is for the automatic + -- close operations done as part of finalization. + + procedure AFCB_Free (File : access AFCB) is abstract; + -- Frees the AFCB referenced by the given parameter. It is not necessary + -- to free the strings referenced by the Form and Name fields, but if the + -- extension has any other heap objects, they must be freed as well. This + -- procedure must be overridden by each individual file package. + +end System.File_Control_Block; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb new file mode 100644 index 00000000000..21548568a33 --- /dev/null +++ b/gcc/ada/s-fileio.adb @@ -0,0 +1,1041 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.59 $ +-- -- +-- 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.Finalization; use Ada.Finalization; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.Soft_Links; +with Unchecked_Deallocation; + +package body System.File_IO is + + use System.File_Control_Block; + + package SSL renames System.Soft_Links; + + ---------------------- + -- Global Variables -- + ---------------------- + + Open_Files : AFCB_Ptr; + -- This points to a list of AFCB's for all open files. This is a doubly + -- linked list, with the Prev pointer of the first entry, and the Next + -- pointer of the last entry containing null. Note that this global + -- variable must be properly protected to provide thread safety. + + type Temp_File_Record; + type Temp_File_Record_Ptr is access all Temp_File_Record; + + type Temp_File_Record is record + Name : String (1 .. L_tmpnam + 1); + Next : Temp_File_Record_Ptr; + end record; + -- One of these is allocated for each temporary file created + + Temp_Files : Temp_File_Record_Ptr; + -- Points to list of names of temporary files. Note that this global + -- variable must be properly protected to provide thread safety. + + type File_IO_Clean_Up_Type is new Controlled with null record; + -- The closing of all open files and deletion of temporary files is an + -- action which takes place at the end of execution of the main program. + -- This action can be implemented using a library level object which + -- gets finalized at the end of the main program execution. The above is + -- a controlled type introduced for this purpose. + + procedure Finalize (V : in out File_IO_Clean_Up_Type); + -- This is the finalize operation that is used to do the cleanup. + + File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; + -- This is the single object of the type that triggers the finalization + -- call. Since it is at the library level, this happens just before the + -- environment task is finalized. + + text_translation_required : Boolean; + pragma Import + (C, text_translation_required, "__gnat_text_translation_required"); + -- If true, add appropriate suffix to control string for Open. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free_String is new Unchecked_Deallocation (String, Pstring); + + subtype Fopen_String is String (1 .. 4); + -- Holds open string (longest is "w+b" & nul) + + procedure Fopen_Mode + (Mode : File_Mode; + Text : Boolean; + Creat : Boolean; + Amethod : Character; + Fopstr : out Fopen_String); + -- Determines proper open mode for a file to be opened in the given + -- Ada mode. Text is true for a text file and false otherwise, and + -- Creat is true for a create call, and False for an open call. The + -- value stored in Fopstr is a nul-terminated string suitable for a + -- call to fopen or freopen. Amethod is the character designating + -- the access method from the Access_Method field of the FCB. + + ---------------- + -- Append_Set -- + ---------------- + + procedure Append_Set (File : AFCB_Ptr) is + begin + if File.Mode = Append_File then + if fseek (File.Stream, 0, SEEK_END) /= 0 then + raise Device_Error; + end if; + end if; + end Append_Set; + + ---------------- + -- Chain_File -- + ---------------- + + procedure Chain_File (File : AFCB_Ptr) is + begin + -- Take a task lock, to protect the global data value Open_Files + -- No exception handler needed, since we cannot get an exception. + + SSL.Lock_Task.all; + File.Next := Open_Files; + File.Prev := null; + Open_Files := File; + + if File.Next /= null then + File.Next.Prev := File; + end if; + + SSL.Unlock_Task.all; + end Chain_File; + + --------------------- + -- Check_File_Open -- + --------------------- + + procedure Check_File_Open (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error; + end if; + end Check_File_Open; + + ----------------------- + -- Check_Read_Status -- + ----------------------- + + procedure Check_Read_Status (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error; + elsif File.Mode > Inout_File then + raise Mode_Error; + end if; + end Check_Read_Status; + + ------------------------ + -- Check_Write_Status -- + ------------------------ + + procedure Check_Write_Status (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error; + elsif File.Mode = In_File then + raise Mode_Error; + end if; + end Check_Write_Status; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out AFCB_Ptr) is + Close_Status : int := 0; + Dup_Strm : Boolean := False; + + begin + Check_File_Open (File); + AFCB_Close (File); + + -- Sever the association between the given file and its associated + -- external file. The given file is left closed. Do not perform system + -- closes on the standard input, output and error files and also do + -- not attempt to close a stream that does not exist (signalled by a + -- null stream value -- happens in some error situations). + + if not File.Is_System_File + and then File.Stream /= NULL_Stream + then + -- Do not do an fclose if this is a shared file and there is + -- at least one other instance of the stream that is open. + + if File.Shared_Status = Yes then + declare + P : AFCB_Ptr; + + begin + P := Open_Files; + while P /= null loop + if P /= File + and then File.Stream = P.Stream + then + Dup_Strm := True; + exit; + end if; + + P := P.Next; + end loop; + end; + end if; + + -- Do the fclose unless this was a duplicate in the shared case + + if not Dup_Strm then + Close_Status := fclose (File.Stream); + end if; + end if; + + -- Dechain file from list of open files and then free the storage + -- Since this is a global data structure, we have to protect against + -- multiple tasks attempting to access this list. + + -- Note that we do not use an exception handler to unlock here since + -- no exception can occur inside the lock/unlock pair. + + begin + SSL.Lock_Task.all; + + if File.Prev = null then + Open_Files := File.Next; + else + File.Prev.Next := File.Next; + end if; + + if File.Next /= null then + File.Next.Prev := File.Prev; + end if; + + SSL.Unlock_Task.all; + end; + + -- Deallocate some parts of the file structure that were kept in heap + -- storage with the exception of system files (standard input, output + -- and error) since they had some information allocated in the stack. + + if not File.Is_System_File then + Free_String (File.Name); + Free_String (File.Form); + AFCB_Free (File); + end if; + + File := null; + + if Close_Status /= 0 then + raise Device_Error; + end if; + end Close; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out AFCB_Ptr) is + begin + Check_File_Open (File); + + if not File.Is_Regular_File then + raise Use_Error; + end if; + + declare + Filename : aliased constant String := File.Name.all; + + begin + Close (File); + + -- Now unlink the external file. Note that we use the full name + -- in this unlink, because the working directory may have changed + -- since we did the open, and we want to unlink the right file! + + if unlink (Filename'Address) = -1 then + raise Use_Error; + end if; + end; + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : AFCB_Ptr) return Boolean is + begin + Check_File_Open (File); + + if feof (File.Stream) /= 0 then + return True; + + else + Check_Read_Status (File); + + if ungetc (fgetc (File.Stream), File.Stream) = EOF then + clearerr (File.Stream); + return True; + else + return False; + end if; + end if; + end End_Of_File; + + -------------- + -- Finalize -- + -------------- + + -- Note: we do not need to worry about locking against multiple task + -- access in this routine, since it is called only from the environment + -- task just before terminating execution. + + procedure Finalize (V : in out File_IO_Clean_Up_Type) is + Discard : int; + Fptr1 : AFCB_Ptr; + Fptr2 : AFCB_Ptr; + + begin + -- First close all open files (the slightly complex form of this loop + -- is required because Close as a side effect nulls out its argument) + + Fptr1 := Open_Files; + while Fptr1 /= null loop + Fptr2 := Fptr1.Next; + Close (Fptr1); + Fptr1 := Fptr2; + end loop; + + -- Now unlink all temporary files. We do not bother to free the + -- blocks because we are just about to terminate the program. We + -- also ignore any errors while attempting these unlink operations. + + while Temp_Files /= null loop + Discard := unlink (Temp_Files.Name'Address); + Temp_Files := Temp_Files.Next; + end loop; + + end Finalize; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : AFCB_Ptr) is + begin + Check_Write_Status (File); + + if fflush (File.Stream) = 0 then + return; + else + raise Device_Error; + end if; + end Flush; + + ---------------- + -- Fopen_Mode -- + ---------------- + + -- The fopen mode to be used is shown by the following table: + + -- OPEN CREATE + -- Append_File "r+" "w+" + -- In_File "r" "w+" + -- Out_File (Direct_IO) "r+" "w" + -- Out_File (all others) "w" "w" + -- Inout_File "r+" "w+" + + -- Note: we do not use "a" or "a+" for Append_File, since this would not + -- work in the case of stream files, where even if in append file mode, + -- you can reset to earlier points in the file. The caller must use the + -- Append_Set routine to deal with the necessary positioning. + + -- Note: in several cases, the fopen mode used allows reading and + -- writing, but the setting of the Ada mode is more restrictive. For + -- instance, Create in In_File mode uses "w+" which allows writing, + -- but the Ada mode In_File will cause any write operations to be + -- rejected with Mode_Error in any case. + + -- Note: for the Out_File/Open cases for other than the Direct_IO case, + -- an initial call will be made by the caller to first open the file in + -- "r" mode to be sure that it exists. The real open, in "w" mode, will + -- then destroy this file. This is peculiar, but that's what Ada semantics + -- require and the ACVT tests insist on! + + -- If text file translation is required, then either b or t is + -- added to the mode, depending on the setting of Text. + + procedure Fopen_Mode + (Mode : File_Mode; + Text : Boolean; + Creat : Boolean; + Amethod : Character; + Fopstr : out Fopen_String) + is + Fptr : Positive; + + begin + case Mode is + when In_File => + if Creat then + Fopstr (1) := 'w'; + Fopstr (2) := '+'; + Fptr := 3; + else + Fopstr (1) := 'r'; + Fptr := 2; + end if; + + when Out_File => + if Amethod = 'D' and not Creat then + Fopstr (1) := 'r'; + Fopstr (2) := '+'; + Fptr := 3; + else + Fopstr (1) := 'w'; + Fptr := 2; + end if; + + when Inout_File | Append_File => + if Creat then + Fopstr (1) := 'w'; + else + Fopstr (1) := 'r'; + end if; + + Fopstr (2) := '+'; + Fptr := 3; + + end case; + + -- If text_translation_required is true then we need to append + -- either a t or b to the string to get the right mode + + if text_translation_required then + if Text then + Fopstr (Fptr) := 't'; + else + Fopstr (Fptr) := 'b'; + end if; + + Fptr := Fptr + 1; + end if; + + Fopstr (Fptr) := ASCII.NUL; + end Fopen_Mode; + + ---------- + -- Form -- + ---------- + + function Form (File : in AFCB_Ptr) return String is + begin + if File = null then + raise Status_Error; + else + return File.Form.all (1 .. File.Form'Length - 1); + end if; + end Form; + + ------------------ + -- Form_Boolean -- + ------------------ + + function Form_Boolean + (Form : String; + Keyword : String; + Default : Boolean) + return Boolean + is + V1, V2 : Natural; + + begin + Form_Parameter (Form, Keyword, V1, V2); + + if V1 = 0 then + return Default; + + elsif Form (V1) = 'y' then + return True; + + elsif Form (V1) = 'n' then + return False; + + else + raise Use_Error; + end if; + end Form_Boolean; + + ------------------ + -- Form_Integer -- + ------------------ + + function Form_Integer + (Form : String; + Keyword : String; + Default : Integer) + return Integer + is + V1, V2 : Natural; + V : Integer; + + begin + Form_Parameter (Form, Keyword, V1, V2); + + if V1 = 0 then + return Default; + + else + V := 0; + + for J in V1 .. V2 loop + if Form (J) not in '0' .. '9' then + raise Use_Error; + else + V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); + end if; + + if V > 999_999 then + raise Use_Error; + end if; + end loop; + + return V; + end if; + end Form_Integer; + + -------------------- + -- Form_Parameter -- + -------------------- + + procedure Form_Parameter + (Form : String; + Keyword : String; + Start : out Natural; + Stop : out Natural) + is + Klen : constant Integer := Keyword'Length; + + -- Start of processing for Form_Parameter + + begin + for J in Form'First + Klen .. Form'Last - 1 loop + if Form (J) = '=' + and then Form (J - Klen .. J - 1) = Keyword + then + Start := J + 1; + Stop := Start - 1; + + while Form (Stop + 1) /= ASCII.NUL + and then Form (Stop + 1) /= ',' + loop + Stop := Stop + 1; + end loop; + + return; + end if; + end loop; + + Start := 0; + Stop := 0; + end Form_Parameter; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : in AFCB_Ptr) return Boolean is + begin + return (File /= null); + end Is_Open; + + ------------------- + -- Make_Buffered -- + ------------------- + + procedure Make_Buffered + (File : AFCB_Ptr; + Buf_Siz : Interfaces.C_Streams.size_t) is + status : Integer; + + begin + status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz); + end Make_Buffered; + + ------------------------ + -- Make_Line_Buffered -- + ------------------------ + + procedure Make_Line_Buffered + (File : AFCB_Ptr; + Line_Siz : Interfaces.C_Streams.size_t) is + status : Integer; + + begin + status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); + end Make_Line_Buffered; + + --------------------- + -- Make_Unbuffered -- + --------------------- + + procedure Make_Unbuffered (File : AFCB_Ptr) is + status : Integer; + + begin + status := setvbuf (File.Stream, Null_Address, IONBF, 0); + end Make_Unbuffered; + + ---------- + -- Mode -- + ---------- + + function Mode (File : in AFCB_Ptr) return File_Mode is + begin + if File = null then + raise Status_Error; + else + return File.Mode; + end if; + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : in AFCB_Ptr) return String is + begin + if File = null then + raise Status_Error; + else + return File.Name.all (1 .. File.Name'Length - 1); + end if; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File_Ptr : in out AFCB_Ptr; + Dummy_FCB : in out AFCB'Class; + Mode : File_Mode; + Name : String; + Form : String; + Amethod : Character; + Creat : Boolean; + Text : Boolean; + C_Stream : FILEs := NULL_Stream) + is + procedure Tmp_Name (Buffer : Address); + pragma Import (C, Tmp_Name, "__gnat_tmp_name"); + -- set buffer (a String address) with a temporary filename. + + Stream : FILEs := C_Stream; + -- Stream which we open in response to this request + + Shared : Shared_Status_Type; + -- Setting of Shared_Status field for file + + Fopstr : aliased Fopen_String; + -- Mode string used in fopen call + + Formstr : aliased String (1 .. Form'Length + 1); + -- Form string with ASCII.NUL appended, folded to lower case + + Tempfile : constant Boolean := (Name'Length = 0); + -- Indicates temporary file case + + Namelen : constant Integer := max_path_len; + -- Length required for file name, not including final ASCII.NUL + -- Note that we used to reference L_tmpnam here, which is not + -- reliable since __gnat_tmp_name does not always use tmpnam. + + Namestr : aliased String (1 .. Namelen + 1); + -- Name as given or temporary file name with ASCII.NUL appended + + Fullname : aliased String (1 .. max_path_len + 1); + -- Full name (as required for Name function, and as stored in the + -- control block in the Name field) with ASCII.NUL appended. + + Full_Name_Len : Integer; + -- Length of name actually stored in Fullname + + begin + if File_Ptr /= null then + raise Status_Error; + end if; + + -- Acquire form string, setting required NUL terminator + + Formstr (1 .. Form'Length) := Form; + Formstr (Formstr'Last) := ASCII.NUL; + + -- Convert form string to lower case + + for J in Formstr'Range loop + if Formstr (J) in 'A' .. 'Z' then + Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32); + end if; + end loop; + + -- Acquire setting of shared parameter + + declare + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "shared", V1, V2); + + if V1 = 0 then + Shared := None; + + elsif Formstr (V1 .. V2) = "yes" then + Shared := Yes; + + elsif Formstr (V1 .. V2) = "no" then + Shared := No; + + else + raise Use_Error; + end if; + end; + + -- If we were given a stream (call from xxx.C_Streams.Open), then set + -- full name to null and that is all we have to do in this case so + -- skip to end of processing. + + if Stream /= NULL_Stream then + Fullname (1) := ASCII.Nul; + Full_Name_Len := 1; + + -- Normal case of Open or Create + + else + -- If temporary file case, get temporary file name and add + -- to the list of temporary files to be deleted on exit. + + if Tempfile then + if not Creat then + raise Name_Error; + end if; + + Tmp_Name (Namestr'Address); + + if Namestr (1) = ASCII.NUL then + raise Use_Error; + end if; + + -- Chain to temp file list, ensuring thread safety with a lock + + begin + SSL.Lock_Task.all; + Temp_Files := + new Temp_File_Record'(Name => Namestr, Next => Temp_Files); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end; + + -- Normal case of non-null name given + + else + Namestr (1 .. Name'Length) := Name; + Namestr (Name'Length + 1) := ASCII.NUL; + end if; + + -- Get full name in accordance with the advice of RM A.8.2(22). + + full_name (Namestr'Address, Fullname'Address); + + if Fullname (1) = ASCII.NUL then + raise Use_Error; + end if; + + for J in Fullname'Range loop + if Fullname (J) = ASCII.NUL then + Full_Name_Len := J; + exit; + end if; + end loop; + + -- If Shared=None or Shared=Yes, then check for the existence + -- of another file with exactly the same full name. + + if Shared /= No then + declare + P : AFCB_Ptr; + + begin + P := Open_Files; + while P /= null loop + if Fullname (1 .. Full_Name_Len) = P.Name.all then + + -- If we get a match, and either file has Shared=None, + -- then raise Use_Error, since we don't allow two + -- files of the same name to be opened unless they + -- specify the required sharing mode. + + if Shared = None + or else P.Shared_Status = None + then + raise Use_Error; + + -- If both files have Shared=Yes, then we acquire the + -- stream from the located file to use as our stream. + + elsif Shared = Yes + and then P.Shared_Status = Yes + then + Stream := P.Stream; + exit; + + -- Otherwise one of the files has Shared=Yes and one + -- has Shared=No. If the current file has Shared=No + -- then all is well but we don't want to share any + -- other file's stream. If the current file has + -- Shared=Yes, we would like to share a stream, but + -- not from a file that has Shared=No, so in either + -- case we just keep going on the search. + + else + null; + end if; + end if; + + P := P.Next; + end loop; + end; + end if; + + -- Open specified file if we did not find an existing stream + + if Stream = NULL_Stream then + Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr); + + -- A special case, if we are opening (OPEN case) a file and + -- the mode returned by Fopen_Mode is not "r" or "r+", then + -- we first make sure that the file exists as required by + -- Ada semantics. + + if Creat = False and then Fopstr (1) /= 'r' then + if file_exists (Namestr'Address) = 0 then + raise Name_Error; + end if; + end if; + + -- Now open the file. Note that we use the name as given + -- in the original Open call for this purpose, since that + -- seems the clearest implementation of the intent. It + -- would presumably work to use the full name here, but + -- if there is any difference, then we should use the + -- name used in the call. + + -- Note: for a corresponding delete, we will use the + -- full name, since by the time of the delete, the + -- current working directory may have changed and + -- we do not want to delete a different file! + + Stream := fopen (Namestr'Address, Fopstr'Address); + + if Stream = NULL_Stream then + if file_exists (Namestr'Address) = 0 then + raise Name_Error; + else + raise Use_Error; + end if; + end if; + end if; + end if; + + -- Stream has been successfully located or opened, so now we are + -- committed to completing the opening of the file. Allocate block + -- on heap and fill in its fields. + + File_Ptr := AFCB_Allocate (Dummy_FCB); + + File_Ptr.Is_Regular_File := (is_regular_file + (fileno (Stream)) /= 0); + File_Ptr.Is_System_File := False; + File_Ptr.Is_Text_File := Text; + File_Ptr.Shared_Status := Shared; + File_Ptr.Access_Method := Amethod; + File_Ptr.Stream := Stream; + File_Ptr.Form := new String'(Formstr); + File_Ptr.Name := new String'(Fullname + (1 .. Full_Name_Len)); + File_Ptr.Mode := Mode; + File_Ptr.Is_Temporary_File := Tempfile; + + Chain_File (File_Ptr); + Append_Set (File_Ptr); + end Open; + + -------------- + -- Read_Buf -- + -------------- + + procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is + Nread : size_t; + + begin + Nread := fread (Buf, 1, Siz, File.Stream); + + if Nread = Siz then + return; + + elsif ferror (File.Stream) /= 0 then + raise Device_Error; + + elsif Nread = 0 then + raise End_Error; + + else -- 0 < Nread < Siz + raise Data_Error; + end if; + + end Read_Buf; + + procedure Read_Buf + (File : AFCB_Ptr; + Buf : Address; + Siz : in Interfaces.C_Streams.size_t; + Count : out Interfaces.C_Streams.size_t) + is + begin + Count := fread (Buf, 1, Siz, File.Stream); + + if Count = 0 and then ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end Read_Buf; + + ----------- + -- Reset -- + ----------- + + -- The reset which does not change the mode simply does a rewind. + + procedure Reset (File : in out AFCB_Ptr) is + begin + Check_File_Open (File); + Reset (File, File.Mode); + end Reset; + + -- The reset with a change in mode is done using freopen, and is + -- not permitted except for regular files (since otherwise there + -- is no name for the freopen, and in any case it seems meaningless) + + procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is + Fopstr : aliased Fopen_String; + + begin + Check_File_Open (File); + + -- Change of mode not allowed for shared file or file with no name + -- or file that is not a regular file, or for a system file. + + if File.Shared_Status = Yes + or else File.Name'Length <= 1 + or else File.Is_System_File + or else (not File.Is_Regular_File) + then + raise Use_Error; + + -- For In_File or Inout_File for a regular file, we can just do a + -- rewind if the mode is unchanged, which is more efficient than + -- doing a full reopen. + + elsif Mode = File.Mode + and then Mode <= Inout_File + then + rewind (File.Stream); + + -- Here the change of mode is permitted, we do it by reopening the + -- file in the new mode and replacing the stream with a new stream. + + else + Fopen_Mode + (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr); + + File.Stream := + freopen (File.Name.all'Address, Fopstr'Address, File.Stream); + + if File.Stream = NULL_Stream then + Close (File); + raise Use_Error; + + else + File.Mode := Mode; + Append_Set (File); + end if; + end if; + end Reset; + + --------------- + -- Write_Buf -- + --------------- + + procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is + begin + -- Note: for most purposes, the Siz and 1 parameters in the fwrite + -- call could be reversed, but on VMS, this is a better choice, since + -- for some file formats, reversing the parameters results in records + -- of one byte each. + + SSL.Abort_Defer.all; + + if fwrite (Buf, Siz, 1, File.Stream) /= 1 then + if Siz /= 0 then + SSL.Abort_Undefer.all; + raise Device_Error; + end if; + end if; + + SSL.Abort_Undefer.all; + end Write_Buf; + +end System.File_IO; diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads new file mode 100644 index 00000000000..fbf3fe17edc --- /dev/null +++ b/gcc/ada/s-fileio.ads @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- 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 provides support for the routines described in (RM A.8.2) +-- which are common to Text_IO, Direct_IO, Sequential_IO and Stream_IO. + +with Interfaces.C_Streams; + +with System.File_Control_Block; + +package System.File_IO is + + package FCB renames System.File_Control_Block; + package ICS renames Interfaces.C_Streams; + + --------------------- + -- File Management -- + --------------------- + + procedure Open + (File_Ptr : in out FCB.AFCB_Ptr; + Dummy_FCB : in out FCB.AFCB'Class; + Mode : FCB.File_Mode; + Name : String; + Form : String; + Amethod : Character; + Creat : Boolean; + Text : Boolean; + C_Stream : ICS.FILEs := ICS.NULL_Stream); + -- This routine is used for both Open and Create calls: + -- + -- File_Ptr is the file type, which must be null on entry + -- (i.e. the file must be closed before the call). + -- + -- Dummy_FCB is a default initialized file control block of appropriate + -- type. Note that the tag of this record indicates the type and length + -- of the control block. This control block is used only for the purpose + -- of providing the controlling argument for calling the write version + -- of Allocate_AFCB. It has no other purpose, and its fields are never + -- read or written. + -- + -- Mode is the required mode + -- + -- Name is the file name, with a null string indicating that a temporary + -- file is to be created (only permitted in create mode, not open mode) + -- + -- Creat is True for a create call, and false for an open call + -- + -- Text is set True to open the file in text mode (w+t or r+t) instead + -- of the usual binary mode open (w+b or r+b). + -- + -- Form is the form string given in the open or create call, this is + -- stored in the AFCB, but otherwise is not used by this or any other + -- routine in this unit (except Form which retrieves the original value) + -- + -- Amethod indicates the access method + -- + -- D = Direct_IO + -- Q = Sequential_IO + -- S = Stream_IO + -- T = Text_IO + -- W = Wide_Text_IO + -- + -- C_Stream is left at its default value for the normal case of an + -- Open or Create call as defined in the RM. The only time this is + -- non-null is for the Open call from Ada.xxx_IO.C_Streams.Open. + -- + -- On return, if the open/create succeeds, then the fields of File are + -- filled in, and this value is copied to the heap. File_Ptr points to + -- this allocated file control block. If the open/create fails, then the + -- fields of File are undefined, and File_Ptr is unchanged. + + procedure Close (File : in out FCB.AFCB_Ptr); + -- The file is closed, all storage associated with it is released, and + -- File is set to null. Note that this routine calls AFCB_Close to perform + -- any specialized close actions, then closes the file at the system level, + -- then frees the mode and form strings, and finally calls AFCB_Free to + -- free the file control block itself, setting File to null. + + procedure Delete (File : in out FCB.AFCB_Ptr); + -- The indicated file is unlinked + + procedure Reset (File : in out FCB.AFCB_Ptr; Mode : in FCB.File_Mode); + -- The file is reset, and the mode changed as indicated. + + procedure Reset (File : in out FCB.AFCB_Ptr); + -- The files is reset, and the mode is unchanged + + function Mode (File : in FCB.AFCB_Ptr) return FCB.File_Mode; + -- Returns the mode as supplied by create, open or reset + + function Name (File : in FCB.AFCB_Ptr) return String; + -- Returns the file name as supplied by Open or Create. Raises Use_Error + -- if used with temporary files or standard files. + + function Form (File : in FCB.AFCB_Ptr) return String; + -- Returns the form as supplied by create, open or reset + -- The string is normalized to all lower case letters. + + function Is_Open (File : in FCB.AFCB_Ptr) return Boolean; + -- Determines if file is open or not + + ---------------------- + -- Utility Routines -- + ---------------------- + + -- Some internal routines not defined in A.8.2. These are routines which + -- provide required common functionality shared by separate packages. + + procedure Chain_File (File : FCB.AFCB_Ptr); + -- Used to chain the given file into the list of open files. Normally this + -- is done implicitly by Open. Chain_File is used for the spcial cases of + -- the system files defined by Text_IO (stdin, stdout, stderr) which are + -- not opened in the normal manner. Note that the caller is responsible + -- for task lock out to protect the global data structures if this is + -- necessary (it is needed for the calls from within this unit itself, + -- but not required for the calls from Text_IO and Wide_Text_IO that + -- are made during elaboration of the environment task). + + procedure Check_File_Open (File : FCB.AFCB_Ptr); + -- If the current file is not open, then Status_Error is raised. + -- Otherwise control returns normally (with File pointing to the + -- control block for the open file. + + procedure Check_Read_Status (File : FCB.AFCB_Ptr); + -- If the current file is not open, then Status_Error is raised. If + -- the file is open, then the mode is checked to ensure that reading + -- is permitted, and if not Mode_Error is raised, otherwise control + -- returns normally. + + procedure Check_Write_Status (File : FCB.AFCB_Ptr); + -- If the current file is not open, then Status_Error is raised. If + -- the file is open, then the mode is checked to ensure that writing + -- is permitted, and if not Mode_Error is raised, otherwise control + -- returns normally. + + function End_Of_File (File : FCB.AFCB_Ptr) return Boolean; + -- File must be opened in read mode. True is returned if the stream is + -- currently positioned at the end of file, otherwise False is returned. + -- The position of the stream is not affected. + + procedure Flush (File : FCB.AFCB_Ptr); + -- Flushes the stream associated with the given file. The file must be + -- open and in write mode (if not, an appropriate exception is raised) + + function Form_Boolean + (Form : String; + Keyword : String; + Default : Boolean) + return Boolean; + -- Searches form string for an entry of the form Keyword=xx where xx is + -- either Yes/No or y/n. Returns True if Yes or Y is found, False if No + -- or N is found. If the keyword parameter is not found, returns the + -- value given as Default. May raise Use_Error if a form string syntax + -- error is detected. Keyword and Form must be in lower case. + + function Form_Integer + (Form : String; + Keyword : String; + Default : Integer) + return Integer; + -- Searches form string for an entry of the form Keyword=xx where xx is + -- an unsigned decimal integer in the range 0 to 999_999. Returns this + -- integer value if it is found. If the keyword parameter is not found, + -- returns the value given as Default. Raise Use_Error if a form string + -- syntax error is detected. Keyword and Form must be in lower case. + + procedure Form_Parameter + (Form : String; + Keyword : String; + Start : out Natural; + Stop : out Natural); + -- Searches form string for an entry of the form Keyword=xx and if found + -- Sets Start and Stop to the first and last characters of xx. Keyword + -- and Form must be in lower case. If no entry matches, then Start and + -- Stop are set to zero on return. Use_Error is raised if a malformed + -- string is detected, but there is no guarantee of full syntax checking. + + procedure Read_Buf + (File : FCB.AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t); + -- Reads Siz bytes from File.Stream into Buf. The caller has checked + -- that the file is open in read mode. Raises an exception if Siz bytes + -- cannot be read (End_Error if no data was read, Data_Error if a partial + -- buffer was read, Device_Error if an error occurs). + + procedure Read_Buf + (File : FCB.AFCB_Ptr; + Buf : Address; + Siz : in Interfaces.C_Streams.size_t; + Count : out Interfaces.C_Streams.size_t); + -- Reads Siz bytes from File.Stream into Buf. The caller has checked + -- that the file is open in read mode. Device Error is raised if an error + -- occurs. Count is the actual number of bytes read, which may be less + -- than Siz if the end of file is encountered. + + procedure Append_Set (File : FCB.AFCB_Ptr); + -- If the mode of the file is Append_File, then the file is positioned + -- at the end of file using fseek, otherwise this call has no effect. + + procedure Write_Buf + (File : FCB.AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t); + -- Writes size_t bytes to File.Stream from Buf. The caller has checked + -- that the file is open in write mode. Raises Device_Error if the + -- complete buffer cannot be written. + + procedure Make_Unbuffered (File : FCB.AFCB_Ptr); + + procedure Make_Line_Buffered + (File : FCB.AFCB_Ptr; + Line_Siz : Interfaces.C_Streams.size_t); + + procedure Make_Buffered + (File : FCB.AFCB_Ptr; + Buf_Siz : Interfaces.C_Streams.size_t); + +private + pragma Inline (Check_Read_Status); + pragma Inline (Check_Write_Status); + pragma Inline (Form); + pragma Inline (Mode); + +end System.File_IO; diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb new file mode 100644 index 00000000000..60df91c6dd1 --- /dev/null +++ b/gcc/ada/s-finimp.adb @@ -0,0 +1,582 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.48 $ +-- -- +-- 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 Ada.Tags; +with Ada.Unchecked_Conversion; +with System.Storage_Elements; +with System.Soft_Links; + +package body System.Finalization_Implementation is + + use Ada.Exceptions; + use System.Finalization_Root; + + package SSL renames System.Soft_Links; + + package SSE renames System.Storage_Elements; + use type SSE.Storage_Offset; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Finalizable_Ptr is + new Ada.Unchecked_Conversion (Address, Finalizable_Ptr); + + function To_Addr is + new Ada.Unchecked_Conversion (Finalizable_Ptr, Address); + + type RC_Ptr is access all Record_Controller; + + function To_RC_Ptr is + new Ada.Unchecked_Conversion (Address, RC_Ptr); + + procedure Raise_Exception_No_Defer + (E : in Exception_Id; + Message : in String := ""); + pragma Import (Ada, Raise_Exception_No_Defer, + "ada__exceptions__raise_exception_no_defer"); + pragma No_Return (Raise_Exception_No_Defer); + -- Raise an exception without deferring abort. Note that we have to + -- use this rather kludgy Ada Import interface, since this subprogram + -- is not available in the visible spec of Ada.Exceptions. + + procedure Raise_From_Finalize + (L : Finalizable_Ptr; + From_Abort : Boolean; + E_Occ : Exception_Occurrence); + -- Deal with an exception raised during finalization of a list. L is a + -- pointer to the list of element not yet finalized. From_Abort is true + -- if the finalization actions come from an abort rather than a normal + -- exit. E_Occ represents the exception being raised. + + function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset; + pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset"); + + function Parent_Size (Obj : Address) return SSE.Storage_Count; + pragma Import (Ada, Parent_Size, "ada__tags__parent_size"); + + function Get_RC_Dynamically (Obj : Address) return Address; + -- Given an the address of an object (obj) of a tagged extension with + -- controlled component, computes the address of the record controller + -- located just after the _parent field + + ------------- + -- Adjust -- + ------------- + + procedure Adjust (Object : in out Record_Controller) is + + First_Comp : Finalizable_Ptr; + My_Offset : constant SSE.Storage_Offset := + Object.My_Address - Object'Address; + + procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr); + -- Substract the offset to the pointer + + procedure Reverse_Adjust (P : Finalizable_Ptr); + -- Ajust the components in the reverse order in which they are stored + -- on the finalization list. (Adjust and Finalization are not done in + -- the same order) + + procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is + begin + if Ptr /= null then + Ptr := To_Finalizable_Ptr (To_Addr (Ptr) - My_Offset); + end if; + end Ptr_Adjust; + + procedure Reverse_Adjust (P : Finalizable_Ptr) is + begin + if P /= null then + Ptr_Adjust (P.Next); + Reverse_Adjust (P.Next); + Adjust (P.all); + Object.F := P; -- Successfully adjusted, so place in list. + end if; + end Reverse_Adjust; + + -- Start of processing for Adjust + + begin + -- Adjust the components and their finalization pointers next. + -- We must protect against an exception in some call to Adjust, so + -- we keep pointing to the list of successfully adjusted components, + -- which can be finalized if an exception is raised. + + First_Comp := Object.F; + Object.F := null; -- nothing adjusted yet. + Ptr_Adjust (First_Comp); -- set addresss of first component. + Reverse_Adjust (First_Comp); + + -- Then Adjust the controller itself + + Object.My_Address := Object'Address; + + exception + when others => + -- Finalize those components that were successfully adjusted, and + -- propagate exception. The object itself is not yet attached to + -- global finalization list, so we cannot rely on the outer call + -- to Clean to take care of these components. + + Finalize (Object); + raise; + end Adjust; + + -------------------------- + -- Attach_To_Final_List -- + -------------------------- + + procedure Attach_To_Final_List + (L : in out Finalizable_Ptr; + Obj : in out Finalizable; + Nb_Link : Short_Short_Integer) + is + begin + -- Simple case: attachement to a one way list + + if Nb_Link = 1 then + Obj.Next := L; + L := Obj'Unchecked_Access; + + -- Dynamically allocated objects: they are attached to a doubly + -- linked list, so that an element can be finalized at any moment + -- by means of an unchecked deallocation. Attachement is + -- protected against multi-threaded access. + + elsif Nb_Link = 2 then + + Locked_Processing : begin + SSL.Lock_Task.all; + Obj.Next := L.Next; + Obj.Prev := L.Next.Prev; + L.Next.Prev := Obj'Unchecked_Access; + L.Next := Obj'Unchecked_Access; + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + -- Attachement of arrays to the final list (used only for objects + -- returned by function). Obj, in this case is the last element, + -- but all other elements are already threaded after it. We just + -- attach the rest of the final list at the end of the array list. + + elsif Nb_Link = 3 then + declare + P : Finalizable_Ptr := Obj'Unchecked_Access; + + begin + while P.Next /= null loop + P := P.Next; + end loop; + + P.Next := L; + L := Obj'Unchecked_Access; + end; + end if; + + end Attach_To_Final_List; + + --------------------- + -- Deep_Tag_Adjust -- + --------------------- + + procedure Deep_Tag_Adjust + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer) + is + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); + Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag); + + Controller : RC_Ptr; + + begin + -- Has controlled components + + if Offset /= 0 then + if Offset > 0 then + Controller := To_RC_Ptr (A + Offset); + else + Controller := To_RC_Ptr (Get_RC_Dynamically (A)); + end if; + + Adjust (Controller.all); + Attach_To_Final_List (L, Controller.all, B); + + -- Is controlled + + elsif V.all in Finalizable then + Adjust (V.all); + Attach_To_Final_List (L, Finalizable (V.all), 1); + end if; + end Deep_Tag_Adjust; + + --------------------- + -- Deep_Tag_Attach -- + ---------------------- + + procedure Deep_Tag_Attach + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer) + is + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); + Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag); + + Controller : RC_Ptr; + + begin + if Offset /= 0 then + if Offset > 0 then + Controller := To_RC_Ptr (A + Offset); + else + Controller := To_RC_Ptr (Get_RC_Dynamically (A)); + end if; + + Attach_To_Final_List (L, Controller.all, B); + + -- Is controlled + + elsif V.all in Finalizable then + Attach_To_Final_List (L, V.all, B); + end if; + end Deep_Tag_Attach; + + ----------------------- + -- Deep_Tag_Finalize -- + ----------------------- + + procedure Deep_Tag_Finalize + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Boolean) + is + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); + Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag); + + Controller : RC_Ptr; + + begin + -- Has controlled components + + if Offset /= 0 then + if Offset > 0 then + Controller := To_RC_Ptr (A + Offset); + else + Controller := To_RC_Ptr (Get_RC_Dynamically (A)); + end if; + + if B then + Finalize_One (Controller.all); + else + Finalize (Controller.all); + end if; + + -- Is controlled + + elsif V.all in Finalizable then + if B then + Finalize_One (V.all); + else + Finalize (V.all); + end if; + end if; + end Deep_Tag_Finalize; + + ------------------------- + -- Deep_Tag_Initialize -- + ------------------------- + + procedure Deep_Tag_Initialize + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer) + is + V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A); + Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag); + + Controller : RC_Ptr; + + begin + -- This procedure should not be called if the object has no + -- controlled components + + if Offset = 0 then + + raise Program_Error; + + -- Has controlled components + + else + if Offset > 0 then + Controller := To_RC_Ptr (A + Offset); + else + Controller := To_RC_Ptr (Get_RC_Dynamically (A)); + end if; + end if; + + Initialize (Controller.all); + Attach_To_Final_List (L, Controller.all, B); + + -- Is controlled + + if V.all in Finalizable then + Initialize (V.all); + Attach_To_Final_List (Controller.F, Finalizable (Controller.all), 1); + end if; + end Deep_Tag_Initialize; + + ----------------------------- + -- Detach_From_Final_List -- + ----------------------------- + + -- We know that the detach object is neither at the beginning nor at the + -- end of the list, thank's to the dummy First and Last Elements but the + -- object may not be attached at all if it is Finalize_Storage_Only + + procedure Detach_From_Final_List (Obj : in out Finalizable) is + begin + + -- When objects are not properly attached to a doubly linked + -- list do not try to detach them. The only case where it can + -- happen is when dealing with Finalize_Storage_Only objects + -- which are not always attached. + + if Obj.Next /= null and then Obj.Prev /= null then + SSL.Lock_Task.all; + Obj.Next.Prev := Obj.Prev; + Obj.Prev.Next := Obj.Next; + SSL.Unlock_Task.all; + end if; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Detach_From_Final_List; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Limited_Record_Controller) is + begin + Finalize_List (Object.F); + end Finalize; + + -------------------------- + -- Finalize_Global_List -- + -------------------------- + + procedure Finalize_Global_List is + begin + -- There are three case here: + -- a. the application uses tasks, in which case Finalize_Global_Tasks + -- will defer abortion + -- b. the application doesn't use tasks but uses other tasking + -- constructs, such as ATCs and protected objects. In this case, + -- the binder will call Finalize_Global_List instead of + -- Finalize_Global_Tasks, letting abort undeferred, and leading + -- to assertion failures in the GNULL + -- c. the application doesn't use any tasking construct in which case + -- deferring abort isn't necessary. + -- + -- Until another solution is found to deal with case b, we need to + -- call abort_defer here to pass the checks, but we do not need to + -- undefer abortion, since Finalize_Global_List is the last procedure + -- called before exiting the partition. + + SSL.Abort_Defer.all; + Finalize_List (Global_Final_List); + end Finalize_Global_List; + + ------------------- + -- Finalize_List -- + ------------------- + + procedure Finalize_List (L : Finalizable_Ptr) is + P : Finalizable_Ptr := L; + Q : Finalizable_Ptr; + + type Fake_Exception_Occurence is record + Id : Exception_Id; + end record; + type Ptr is access all Fake_Exception_Occurence; + + -- Let's get the current exception before starting to finalize in + -- order to check if we are in the abort case if an exception is + -- raised. + + function To_Ptr is new + Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr); + X : Exception_Id := + To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id; + + begin + while P /= null loop + Q := P.Next; + Finalize (P.all); + P := Q; + end loop; + + exception + when E_Occ : others => + Raise_From_Finalize ( + Q, + X = Standard'Abort_Signal'Identity, + E_Occ); + end Finalize_List; + + ------------------ + -- Finalize_One -- + ------------------ + + procedure Finalize_One (Obj : in out Finalizable) is + begin + Detach_From_Final_List (Obj); + Finalize (Obj); + + exception + when E_Occ : others => Raise_From_Finalize (null, False, E_Occ); + end Finalize_One; + + ------------------------ + -- Get_RC_Dynamically -- + ------------------------ + + function Get_RC_Dynamically (Obj : Address) return Address is + + -- define a faked record controller to avoid generating + -- unnecessary expanded code for controlled types + + type Faked_Record_Controller is record + Tag, Prec, Next : Address; + end record; + + -- Reconstruction of a type with characteristics + -- comparable to the original type + + D : constant := Storage_Unit - 1; + + type Faked_Type_Of_Obj is record + Parent : SSE.Storage_Array + (1 .. (Parent_Size (Obj) + D) / Storage_Unit); + Controller : Faked_Record_Controller; + end record; + + type Obj_Ptr is access all Faked_Type_Of_Obj; + function To_Obj_Ptr is new Ada.Unchecked_Conversion (Address, Obj_Ptr); + + begin + return To_Obj_Ptr (Obj).Controller'Address; + end Get_RC_Dynamically; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Limited_Record_Controller) is + begin + null; + end Initialize; + + procedure Initialize (Object : in out Record_Controller) is + begin + Object.My_Address := Object'Address; + end Initialize; + + ------------------------- + -- Raise_From_Finalize -- + ------------------------- + + procedure Raise_From_Finalize + (L : Finalizable_Ptr; + From_Abort : Boolean; + E_Occ : Exception_Occurrence) + is + Msg : constant String := Exception_Message (E_Occ); + P : Finalizable_Ptr := L; + Q : Finalizable_Ptr; + + begin + -- We already got an exception. We now finalize the remainder of + -- the list, ignoring all further exceptions. + + while P /= null loop + Q := P.Next; + + begin + Finalize (P.all); + exception + when others => null; + end; + + P := Q; + end loop; + + -- If finalization from an Abort, then nothing to do + + if From_Abort then + null; + + -- If no message, then add our own message saying what happened + + elsif Msg = "" then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => "exception " & + Exception_Name (E_Occ) & + " raised during finalization"); + + -- If there was a message, pass it on + + else + Raise_Exception_No_Defer (Program_Error'Identity, Msg); + end if; + end Raise_From_Finalize; + +-- Initialization of package, set Adafinal soft link + +begin + SSL.Adafinal := Finalize_Global_List'Access; + +end System.Finalization_Implementation; diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads new file mode 100644 index 00000000000..49db440a0ec --- /dev/null +++ b/gcc/ada/s-finimp.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.31 $ -- +-- -- +-- 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 System.Finalization_Root; + +package System.Finalization_Implementation is +pragma Elaborate_Body (Finalization_Implementation); + + package SFR renames System.Finalization_Root; + + ------------------------------------------------ + -- Finalization Management Abstract Interface -- + ------------------------------------------------ + + Global_Final_List : SFR.Finalizable_Ptr; + -- This list stores the controlled objects defined in library-level + -- packages. They will be finalized after the main program completion. + + procedure Finalize_Global_List; + -- The procedure to be called in order to finalize the global list; + + procedure Attach_To_Final_List + (L : in out SFR.Finalizable_Ptr; + Obj : in out SFR.Finalizable; + Nb_Link : Short_Short_Integer); + -- Attach finalizable object Obj to the linked list L. Nb_Link controls + -- the number of link of the linked_list, and can be either 0 for no + -- attachement, 1 for simple linked lists or 2 for doubly linked lists + -- or even 3 for a simple attachement of a whole array of elements. + -- Attachement to a simply linked list is not protected against + -- concurrent access and should only be used in context where it + -- doesn't matter, such as for objects allocated on the stack. In the + -- case of an attachment on a doubly linked list, L must not be null + -- and Obj will be inserted AFTER the first element and the attachment + -- is protected against concurrent call. Typically used to attach to + -- a dynamically allocated object to a List_Controller (whose first + -- element is always a dummy element) + + procedure Finalize_List (L : SFR.Finalizable_Ptr); + -- Call Finalize on each element of the list L; + + procedure Finalize_One (Obj : in out SFR.Finalizable); + -- Call Finalize on Obj and remove its final list. + + --------------------- + -- Deep Procedures -- + --------------------- + + procedure Deep_Tag_Initialize + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer); + -- Generic initialize for tagged objects with controlled components. A + -- is the address of the object, L the finalization list when it needs + -- to be attached and B the attachement level (see Attach_To_Final_List) + + procedure Deep_Tag_Adjust + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer); + -- Generic adjust for tagged objects with controlled components. A + -- is the address of the object, L the finalization list when it needs + -- to be attached and B the attachement level (see Attach_To_Final_List) + + procedure Deep_Tag_Finalize + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Boolean); + -- Generic finalize for tagged objects with controlled components. A + -- is the address of the object, L the finalization list when it needs + -- to be attached and B the attachement level (see Attach_To_Final_List) + + procedure Deep_Tag_Attach + (L : in out SFR.Finalizable_Ptr; + A : System.Address; + B : Short_Short_Integer); + -- Generic attachement for tagged objects with controlled components. A + -- is the address of the object, L the finalization list when it needs + -- to be attached and B the attachement level (see Attach_To_Final_List) + + ----------------------------- + -- Record Controller Types -- + ----------------------------- + + -- Definition of the types of the controller component that is included + -- in records containing controlled components. This controller is + -- attached to the finalization chain of the upper-level and carries + -- the pointer of the finalization chain for the lower level + + type Limited_Record_Controller is new SFR.Root_Controlled with record + F : SFR.Finalizable_Ptr; + end record; + + procedure Initialize (Object : in out Limited_Record_Controller); + -- Does nothing + + procedure Finalize (Object : in out Limited_Record_Controller); + -- Finalize the controlled components of the enclosing record by + -- following the list starting at Object.F + + type Record_Controller is + new Limited_Record_Controller with record + My_Address : System.Address; + end record; + + procedure Initialize (Object : in out Record_Controller); + -- Initialize the field My_Address to the Object'Address + + procedure Adjust (Object : in out Record_Controller); + -- Adjust the components and their finalization pointers by substracting + -- by the offset of the target and the source addresses of the assignment + + -- Inherit Finalize from Limited_Record_Controller + + procedure Detach_From_Final_List (Obj : in out SFR.Finalizable); + -- Remove the specified object from its Final list which must be a + -- doubly linked list. + +end System.Finalization_Implementation; diff --git a/gcc/ada/s-finroo.adb b/gcc/ada/s-finroo.adb new file mode 100644 index 00000000000..fba98865ab3 --- /dev/null +++ b/gcc/ada/s-finroo.adb @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ R O O T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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 System.Finalization_Root is + + -- It should not be possible to call any of these subprograms + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Root_Controlled) is + begin + raise Program_Error; + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Root_Controlled) is + begin + raise Program_Error; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Root_Controlled) is + begin + raise Program_Error; + end Initialize; + + ---------- + -- Read -- + ---------- + + -- Read and Write must be empty in order to avoid copying the + -- finalization pointers. + + pragma Warnings (Off); + -- Suppress warning for out paramater Item which is not assigned + -- because it is pretty much empty. + + procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : out Root_Controlled) + is + begin + null; + end Read; + + ----------- + -- Write -- + ----------- + + -- Read and Write must be empty in order to avoid copying the + -- finalization pointers. + + procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : in Root_Controlled) + is + begin + null; + end Write; + +end System.Finalization_Root; diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads new file mode 100644 index 00000000000..d853cf4e2b5 --- /dev/null +++ b/gcc/ada/s-finroo.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ R O O T -- +-- -- +-- S p e c -- +-- -- +-- $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.Streams; +package System.Finalization_Root is +pragma Preelaborate (Finalization_Root); + + type Root_Controlled; + + type Finalizable_Ptr is access all Root_Controlled'Class; + + type Empty_Root_Controlled is abstract tagged null record; + -- Just for the sake of Controlled equality (see Ada.Finalization) + + type Root_Controlled is new Empty_Root_Controlled with record + Prev, Next : Finalizable_Ptr; + end record; + subtype Finalizable is Root_Controlled'Class; + + procedure Initialize (Object : in out Root_Controlled); + procedure Finalize (Object : in out Root_Controlled); + procedure Adjust (Object : in out Root_Controlled); + + procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : in Root_Controlled); + procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : out Root_Controlled); + + for Root_Controlled'Read use Read; + for Root_Controlled'Write use Write; +end System.Finalization_Root; diff --git a/gcc/ada/s-fore.adb b/gcc/ada/s-fore.adb new file mode 100644 index 00000000000..b5d686ed0ae --- /dev/null +++ b/gcc/ada/s-fore.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- 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 System.Fore is + + ---------- + -- Fore -- + ---------- + + function Fore (Lo, Hi : Long_Long_Float) return Natural is + T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi); + R : Natural; + + begin + -- Initial value of 2 allows for sign and mandatory single digit + + R := 2; + + -- Loop to increase Fore as needed to include full range of values + + while T >= 10.0 loop + T := T / 10.0; + R := R + 1; + end loop; + + return R; + end Fore; +end System.Fore; diff --git a/gcc/ada/s-fore.ads b/gcc/ada/s-fore.ads new file mode 100644 index 00000000000..8f95d40481b --- /dev/null +++ b/gcc/ada/s-fore.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute + +package System.Fore is +pragma Pure (Fore); + + function Fore (Lo, Hi : Long_Long_Float) return Natural; + -- Compute Fore attribute value for a fixed-point type. The parameters + -- are the low and high bounds values, converted to Long_Long_Float. + +end System.Fore; diff --git a/gcc/ada/s-gloloc.adb b/gcc/ada/s-gloloc.adb new file mode 100644 index 00000000000..73d69df1185 --- /dev/null +++ b/gcc/ada/s-gloloc.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Task_Lock; + +package body System.Global_Locks is + + type String_Access is access String; + + package TSL renames GNAT.Task_Lock; + + Dir_Separator : Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + + type Lock_File_Entry is + record + Dir : String_Access; + File : String_Access; + end record; + + Last_Lock : Lock_Type := Null_Lock; + Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; + + procedure Lock_File + (Dir : String; + File : String; + Wait : Duration := 0.1; + Retries : Natural := Natural'Last); + -- Create a lock file File in directory Dir. If the file cannot be + -- locked because someone already owns the lock, this procedure + -- waits Wait seconds and retries at most Retries times. If the file + -- still cannot be locked, Lock_Error is raised. The default is to try + -- every second, almost forever (Natural'Last times). + + ------------------ + -- Acquire_Lock -- + ------------------ + + procedure Acquire_Lock + (Lock : in out Lock_Type) + is + begin + Lock_File + (Lock_Table (Lock).Dir.all, + Lock_Table (Lock).File.all); + end Acquire_Lock; + + ----------------- + -- Create_Lock -- + ----------------- + + procedure Create_Lock + (Lock : out Lock_Type; + Name : in String) + is + L : Lock_Type; + + begin + TSL.Lock; + Last_Lock := Last_Lock + 1; + L := Last_Lock; + TSL.Unlock; + + if L > Lock_Table'Last then + raise Lock_Error; + end if; + + for J in reverse Name'Range loop + if Name (J) = Dir_Separator then + Lock_Table (L).Dir + := new String'(Name (Name'First .. J - 1)); + Lock_Table (L).File + := new String'(Name (J + 1 .. Name'Last)); + exit; + end if; + end loop; + + if Lock_Table (L).Dir = null then + Lock_Table (L).Dir := new String'("."); + Lock_Table (L).File := new String'(Name); + end if; + + Lock := L; + end Create_Lock; + + --------------- + -- Lock_File -- + --------------- + + procedure Lock_File + (Dir : String; + File : String; + Wait : Duration := 0.1; + Retries : Natural := Natural'Last) + is + C_Dir : aliased String := Dir & ASCII.NUL; + C_File : aliased String := File & ASCII.NUL; + + function Try_Lock (Dir, File : System.Address) return Integer; + pragma Import (C, Try_Lock, "__gnat_try_lock"); + + begin + for I in 0 .. Retries loop + if Try_Lock (C_Dir'Address, C_File'Address) = 1 then + return; + end if; + exit when I = Retries; + delay Wait; + end loop; + raise Lock_Error; + end Lock_File; + + ------------------ + -- Release_Lock -- + ------------------ + + procedure Release_Lock + (Lock : in out Lock_Type) + is + S : aliased String := + Lock_Table (Lock).Dir.all & Dir_Separator & + Lock_Table (Lock).File.all & ASCII.NUL; + + procedure unlink (A : System.Address); + pragma Import (C, unlink, "unlink"); + + begin + unlink (S'Address); + end Release_Lock; + +end System.Global_Locks; diff --git a/gcc/ada/s-gloloc.ads b/gcc/ada/s-gloloc.ads new file mode 100644 index 00000000000..3129044bbf9 --- /dev/null +++ b/gcc/ada/s-gloloc.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + + -- This package contains the necessary routines to provide + -- reliable system wide locking capability. + +package System.Global_Locks is + + Lock_Error : exception; + -- Exception raised if a request cannot be executed on a lock. + + type Lock_Type is private; + -- Such a lock is a global lock between partitions. This lock is + -- uniquely defined between the partitions because of its name. + + Null_Lock : constant Lock_Type; + + procedure Create_Lock + (Lock : out Lock_Type; + Name : in String); + -- Create or retrieve a global lock for the current partition using + -- its Name. + + procedure Acquire_Lock + (Lock : in out Lock_Type); + -- If the lock cannot be acquired because someone already owns it, this + -- procedure is supposed to wait and retry forever. + + procedure Release_Lock + (Lock : in out Lock_Type); + +private + + type Lock_Type is new Natural; + + Null_Lock : constant Lock_Type := 0; + +end System.Global_Locks; diff --git a/gcc/ada/s-imgbiu.adb b/gcc/ada/s-imgbiu.adb new file mode 100644 index 00000000000..337a4c3baf4 --- /dev/null +++ b/gcc/ada/s-imgbiu.adb @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B I U -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_BIU is + + ----------------------------- + -- Set_Image_Based_Integer -- + ----------------------------- + + procedure Set_Image_Based_Integer + (V : Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Based_Integer; + + ------------------------------ + -- Set_Image_Based_Unsigned -- + ------------------------------ + + procedure Set_Image_Based_Unsigned + (V : Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + BU : constant Unsigned := Unsigned (B); + Hex : constant array + (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF"; + + procedure Set_Digits (T : Unsigned); + -- Set digits of absolute value of T + + procedure Set_Digits (T : Unsigned) is + begin + if T >= BU then + Set_Digits (T / BU); + P := P + 1; + S (P) := Hex (T mod BU); + else + P := P + 1; + S (P) := Hex (T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Based_Unsigned + + begin + + if B >= 10 then + P := P + 1; + S (P) := '1'; + end if; + + P := P + 1; + S (P) := Character'Val (Character'Pos ('0') + B mod 10); + + P := P + 1; + S (P) := '#'; + + Set_Digits (V); + + P := P + 1; + S (P) := '#'; + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := Start + W; + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Based_Unsigned; + +end System.Img_BIU; diff --git a/gcc/ada/s-imgbiu.ads b/gcc/ada/s-imgbiu.ads new file mode 100644 index 00000000000..c01fe7b756c --- /dev/null +++ b/gcc/ada/s-imgbiu.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B I U -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image in based format of signed and +-- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO +-- and Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_BIU is +pragma Pure (Img_BIU); + + procedure Set_Image_Based_Integer + (V : Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes a leading minus sign if necessary, but no leading + -- spaces unless W is positive, in which case leading spaces are output if + -- necessary to ensure that the output string is no less than W characters + -- long. The caller promises that the buffer is large enough and no check + -- is made for this. Constraint_Error will not necessarily be raised if + -- this is violated, since it is perfectly valid to compile this unit with + -- checks off. + + procedure Set_Image_Based_Unsigned + (V : System.Unsigned_Types.Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes no leading spaces unless W is positive, in which case + -- leading spaces are output if necessary to ensure that the output string + -- is no less than W characters long. The caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). + +end System.Img_BIU; diff --git a/gcc/ada/s-imgboo.adb b/gcc/ada/s-imgboo.adb new file mode 100644 index 00000000000..0ab8a3004bc --- /dev/null +++ b/gcc/ada/s-imgboo.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B O O L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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 System.Img_Bool is + + ------------------- + -- Image_Boolean -- + ------------------- + + function Image_Boolean (V : Boolean) return String is + begin + if V then + return "TRUE"; + else + return "FALSE"; + end if; + end Image_Boolean; + +end System.Img_Bool; diff --git a/gcc/ada/s-imgboo.ads b/gcc/ada/s-imgboo.ads new file mode 100644 index 00000000000..30f03c6240c --- /dev/null +++ b/gcc/ada/s-imgboo.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B O O L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Boolean'Image + +package System.Img_Bool is +pragma Pure (Img_Bool); + + function Image_Boolean (V : Boolean) return String; + -- Computes Boolean'Image (V) and returns the result. + +end System.Img_Bool; diff --git a/gcc/ada/s-imgcha.adb b/gcc/ada/s-imgcha.adb new file mode 100644 index 00000000000..aab81bc8b42 --- /dev/null +++ b/gcc/ada/s-imgcha.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.11 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.Img_Char is + + --------------------- + -- Image_Character -- + --------------------- + + function Image_Character (V : Character) return String is + subtype Cname is String (1 .. 3); + + S : Cname; + + subtype C0_Range is Character + range Character'Val (16#00#) .. Character'Val (16#1F#); + + C0 : constant array (C0_Range) of Cname := + (Character'Val (16#00#) => "NUL", + Character'Val (16#01#) => "SOH", + Character'Val (16#02#) => "STX", + Character'Val (16#03#) => "ETX", + Character'Val (16#04#) => "EOT", + Character'Val (16#05#) => "ENQ", + Character'Val (16#06#) => "ACK", + Character'Val (16#07#) => "BEL", + Character'Val (16#08#) => "BS ", + Character'Val (16#09#) => "HT ", + Character'Val (16#0A#) => "LF ", + Character'Val (16#0B#) => "VT ", + Character'Val (16#0C#) => "FF ", + Character'Val (16#0D#) => "CR ", + Character'Val (16#0E#) => "SO ", + Character'Val (16#0F#) => "SI ", + Character'Val (16#10#) => "DLE", + Character'Val (16#11#) => "DC1", + Character'Val (16#12#) => "DC2", + Character'Val (16#13#) => "DC3", + Character'Val (16#14#) => "DC4", + Character'Val (16#15#) => "NAK", + Character'Val (16#16#) => "SYN", + Character'Val (16#17#) => "ETB", + Character'Val (16#18#) => "CAN", + Character'Val (16#19#) => "EM ", + Character'Val (16#1A#) => "SUB", + Character'Val (16#1B#) => "ESC", + Character'Val (16#1C#) => "FS ", + Character'Val (16#1D#) => "GS ", + Character'Val (16#1E#) => "RS ", + Character'Val (16#1F#) => "US "); + + subtype C1_Range is Character + range Character'Val (16#7F#) .. Character'Val (16#9F#); + + C1 : constant array (C1_Range) of Cname := + (Character'Val (16#7F#) => "DEL", + Character'Val (16#80#) => "res", + Character'Val (16#81#) => "res", + Character'Val (16#82#) => "BPH", + Character'Val (16#83#) => "NBH", + Character'Val (16#84#) => "res", + Character'Val (16#85#) => "NEL", + Character'Val (16#86#) => "SSA", + Character'Val (16#87#) => "ESA", + Character'Val (16#88#) => "HTS", + Character'Val (16#89#) => "HTJ", + Character'Val (16#8A#) => "VTS", + Character'Val (16#8B#) => "PLD", + Character'Val (16#8C#) => "PLU", + Character'Val (16#8D#) => "RI ", + Character'Val (16#8E#) => "SS2", + Character'Val (16#8F#) => "SS3", + Character'Val (16#90#) => "DCS", + Character'Val (16#91#) => "PU1", + Character'Val (16#92#) => "PU2", + Character'Val (16#93#) => "STS", + Character'Val (16#94#) => "CCH", + Character'Val (16#95#) => "MW ", + Character'Val (16#96#) => "SPA", + Character'Val (16#97#) => "EPA", + Character'Val (16#98#) => "SOS", + Character'Val (16#99#) => "res", + Character'Val (16#9A#) => "SCI", + Character'Val (16#9B#) => "CSI", + Character'Val (16#9C#) => "ST ", + Character'Val (16#9D#) => "OSC", + Character'Val (16#9E#) => "PM ", + Character'Val (16#9F#) => "APC"); + + begin + -- Control characters are represented by their names (RM 3.5(32)) + + if V in C0_Range then + S := C0 (V); + + if S (3) = ' ' then + return S (1 .. 2); + else + return S; + end if; + + elsif V in C1_Range then + S := C1 (V); + + if S (1) /= 'r' then + if S (3) = ' ' then + return S (1 .. 2); + else + return S; + end if; + + -- Special case, res means RESERVED_nnn where nnn is the three digit + -- decimal value corresponding to the code position (more efficient + -- to compute than to store!) + + else + declare + VP : constant Natural := Character'Pos (V); + St : String (1 .. 12) := "RESERVED_xxx"; + + begin + St (10) := Character'Val (48 + VP / 100); + St (11) := Character'Val (48 + (VP / 10) mod 10); + St (12) := Character'Val (48 + VP mod 10); + return St; + end; + end if; + + -- Normal characters yield the character enlosed in quotes (RM 3.5(32)) + + else + S (1) := '''; + S (2) := V; + S (3) := '''; + return S; + end if; + end Image_Character; + +end System.Img_Char; diff --git a/gcc/ada/s-imgcha.ads b/gcc/ada/s-imgcha.ads new file mode 100644 index 00000000000..d4639cfd491 --- /dev/null +++ b/gcc/ada/s-imgcha.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Character'Image + +package System.Img_Char is +pragma Pure (Img_Char); + + function Image_Character (V : Character) return String; + -- Computes Character'Image (V) and returns the result + + +end System.Img_Char; diff --git a/gcc/ada/s-imgdec.adb b/gcc/ada/s-imgdec.adb new file mode 100644 index 00000000000..0ac4a8bf1cd --- /dev/null +++ b/gcc/ada/s-imgdec.adb @@ -0,0 +1,359 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C -- +-- -- +-- 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 System.Img_Int; use System.Img_Int; + +package body System.Img_Dec is + + ------------------- + -- Image_Decimal -- + ------------------- + + function Image_Decimal + (V : Integer; + Scale : Integer) + return String + is + P : Natural := 0; + S : String (1 .. 64); + + begin + Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); + + -- Mess around to make sure we have the objectionable space at the + -- start for positive numbers in accordance with the annoying rules! + + if S (1) /= ' ' and then S (1) /= '-' then + S (2 .. P + 1) := S (1 .. P); + S (1) := ' '; + return S (1 .. P + 1); + else + return S (1 .. P); + end if; + end Image_Decimal; + + ------------------------ + -- Set_Decimal_Digits -- + ------------------------ + + procedure Set_Decimal_Digits + (Digs : in out String; + NDigs : Natural; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + Minus : constant Boolean := (Digs (1) = '-'); + -- Set True if input is negative + + Zero : Boolean := (Digs (2) = '0'); + -- Set True if input is exactly zero (only case when a leading zero + -- is permitted in the input string given to this procedure). This + -- flag can get set later if rounding causes the value to become zero. + + FD : Natural := 2; + -- First digit position of digits remaining to be processed + + LD : Natural := NDigs; + -- Last digit position of digits remaining to be processed + + ND : Natural := NDigs - 1; + -- Number of digits remaining to be processed (LD - FD + 1) + + Digits_Before_Point : Integer := ND - Scale; + -- Number of digits before decimal point in the input value. This + -- value can be negative if the input value is less than 0.1, so + -- it is an indication of the current exponent. Digits_Before_Point + -- is adjusted if the rounding step generates an extra digit. + + Digits_After_Point : constant Natural := Integer'Max (1, Aft); + -- Digit positions after decimal point in result string + + Expon : Integer; + -- Integer value of exponent + + procedure Round (N : Natural); + -- Round the number in Digs. N is the position of the last digit to be + -- retained in the rounded position (rounding is based on Digs (N + 1) + -- FD, LD, ND are reset as necessary if required. Note that if the + -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be + -- placed in the sign position as a result of the rounding, this is + -- the case in which FD is adjusted. + + procedure Set (C : Character); + pragma Inline (Set); + -- Sets character C in output buffer + + procedure Set_Blanks_And_Sign (N : Integer); + -- Sets leading blanks and minus sign if needed. N is the number of + -- positions to be filled (a minus sign is output even if N is zero + -- or negative, For a positive value, if N is non-positive, then + -- a leading blank is filled. + + procedure Set_Digits (S, E : Natural); + pragma Inline (Set_Digits); + -- Set digits S through E from Digs, no effect if S > E + + procedure Set_Zeroes (N : Integer); + pragma Inline (Set_Zeroes); + -- Set N zeroes, no effect if N is negative + + procedure Round (N : Natural) is + D : Character; + + begin + -- Nothing to do if rounding at or past last digit + + if N >= LD then + return; + + -- Cases of rounding before the initial digit + + elsif N < FD then + + -- The result is zero, unless we are rounding just before + -- the first digit, and the first digit is five or more. + + if N = 1 and then Digs (2) >= '5' then + Digs (1) := '1'; + else + Digs (1) := '0'; + Zero := True; + end if; + + Digits_Before_Point := Digits_Before_Point + 1; + FD := 1; + LD := 1; + ND := 1; + + -- Normal case of rounding an existing digit + + else + LD := N; + ND := LD - 1; + + if Digs (N + 1) >= '5' then + for J in reverse 2 .. N loop + D := Character'Succ (Digs (J)); + + if D <= '9' then + Digs (J) := D; + return; + else + Digs (J) := '0'; + end if; + end loop; + + -- Here the rounding overflows into the sign position. That's + -- OK, because we already captured the value of the sign and + -- we are in any case destroying the value in the Digs buffer + + Digs (1) := '1'; + FD := 1; + ND := ND + 1; + Digits_Before_Point := Digits_Before_Point + 1; + end if; + end if; + end Round; + + procedure Set (C : Character) is + begin + P := P + 1; + S (P) := C; + end Set; + + procedure Set_Blanks_And_Sign (N : Integer) is + W : Integer := N; + + begin + if Minus then + W := W - 1; + + for J in 1 .. W loop + Set (' '); + end loop; + + Set ('-'); + + else + for J in 1 .. W loop + Set (' '); + end loop; + end if; + end Set_Blanks_And_Sign; + + procedure Set_Digits (S, E : Natural) is + begin + for J in S .. E loop + Set (Digs (J)); + end loop; + end Set_Digits; + + procedure Set_Zeroes (N : Integer) is + begin + for J in 1 .. N loop + Set ('0'); + end loop; + end Set_Zeroes; + + -- Start of processing for Set_Decimal_Digits + + begin + -- Case of exponent given + + if Exp > 0 then + Set_Blanks_And_Sign (Fore - 1); + Round (Aft + 2); + Set (Digs (FD)); + FD := FD + 1; + ND := ND - 1; + Set ('.'); + + if ND >= Digits_After_Point then + Set_Digits (FD, FD + Digits_After_Point - 1); + + else + Set_Digits (FD, LD); + Set_Zeroes (Digits_After_Point - ND); + end if; + + -- Calculate exponent. The number of digits before the decimal point + -- in the input is Digits_Before_Point, and the number of digits + -- before the decimal point in the output is 1, so we can get the + -- exponent as the difference between these two values. The one + -- exception is for the value zero, which by convention has an + -- exponent of +0. + + if Zero then + Expon := 0; + else + Expon := Digits_Before_Point - 1; + end if; + + Set ('E'); + ND := 0; + + if Expon >= 0 then + Set ('+'); + Set_Image_Integer (Expon, Digs, ND); + else + Set ('-'); + Set_Image_Integer (-Expon, Digs, ND); + end if; + + Set_Zeroes (Exp - ND - 1); + Set_Digits (1, ND); + return; + + -- Case of no exponent given. To make these cases clear, we use + -- examples. For all the examples, we assume Fore = 2, Aft = 3. + -- A P in the example input string is an implied zero position, + -- not included in the input string. + + else + -- Round at correct position + -- Input: 4PP => unchanged + -- Input: 400.03 => unchanged + -- Input 3.4567 => 3.457 + -- Input: 9.9999 => 10.000 + -- Input: 0.PPP5 => 0.001 + -- Input: 0.PPP4 => 0 + -- Input: 0.00003 => 0 + + Round (LD - (Scale - Digits_After_Point)); + + -- No digits before point in input + -- Input: .123 Output: 0.123 + -- Input: .PP3 Output: 0.003 + + if Digits_Before_Point <= 0 then + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + Set ('.'); + + Set_Zeroes (Digits_After_Point - ND); + Set_Digits (FD, LD); + + -- At least one digit before point in input + + else + Set_Blanks_And_Sign (Fore - Digits_Before_Point); + + -- Less digits in input than are needed before point + -- Input: 1PP Output: 100.000 + + if ND < Digits_Before_Point then + Set_Digits (FD, LD); + Set_Zeroes (Digits_Before_Point - ND); + Set ('.'); + Set_Zeroes (Digits_After_Point); + + -- Input has full amount of digits before decimal point + + else + Set_Digits (FD, FD + Digits_Before_Point - 1); + Set ('.'); + Set_Digits (FD + Digits_Before_Point, LD); + Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point)); + end if; + end if; + end if; + + end Set_Decimal_Digits; + + ----------------------- + -- Set_Image_Decimal -- + ----------------------- + + procedure Set_Image_Decimal + (V : Integer; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + Digs : String := Image_Integer (V); + -- Sign and digits of decimal value + + begin + Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); + end Set_Image_Decimal; + +end System.Img_Dec; diff --git a/gcc/ada/s-imgdec.ads b/gcc/ada/s-imgdec.ads new file mode 100644 index 00000000000..19cc702ed2e --- /dev/null +++ b/gcc/ada/s-imgdec.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Image for decimal fixed types where the size of the corresponding integer +-- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output) + +package System.Img_Dec is +pragma Preelaborate (Img_Dec); + + function Image_Decimal + (V : Integer; + Scale : Integer) + return String; + -- Compute 'Image of V, the integer value (in units of delta) of a decimal + -- type whose Scale is as given and return the result. THe image is given + -- by the rules in RM 3.5(34) for fixed-point type image functions. + + procedure Set_Image_Decimal + (V : Integer; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V, where V is the integer value (in units of delta) + -- of a decimal type with the given Scale, starting at S (P + 1), updating + -- P to point to the last character stored, the caller promises that the + -- buffer is large enough and no check is made for this. Constraint_Error + -- will not necessarily be raised if this requirement is violated, since + -- it is perfectly valid to compile this unit with checks off. The Fore, + -- Aft and Exp values can be set to any valid values for the case of use + -- by Text_IO.Decimal_IO. + + procedure Set_Decimal_Digits + (Digs : in out String; + NDigs : Natural; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- This procedure has the same semantics as Set_Image_Decimal, except that + -- the value in Digs (1 .. NDigs) is given as a string of decimal digits + -- preceded by either a minus sign or a space (i.e. the integer image of + -- the value in units of delta). The call may destroy the value in Digs, + -- which is why Digs is in-out (this happens if rounding is required). + -- Set_Decimal_Digits is shared by all the decimal image routines. + +end System.Img_Dec; diff --git a/gcc/ada/s-imgenu.adb b/gcc/ada/s-imgenu.adb new file mode 100644 index 00000000000..24d0a29af5e --- /dev/null +++ b/gcc/ada/s-imgenu.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with Unchecked_Conversion; + +package body System.Img_Enum is + + ------------------------- + -- Image_Enumeration_8 -- + ------------------------- + + function Image_Enumeration_8 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String + is + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : Natural := Natural (IndexesT (Pos)); + Next : Natural := Natural (IndexesT (Pos + 1)); + + subtype Result_Type is String (1 .. Next - Start); + -- We need this result type to force the result to have the + -- required lower bound of 1, rather than the slice bounds. + + begin + return Result_Type (Names (Start .. Next - 1)); + end Image_Enumeration_8; + + -------------------------- + -- Image_Enumeration_16 -- + -------------------------- + + function Image_Enumeration_16 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String + is + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : Natural := Natural (IndexesT (Pos)); + Next : Natural := Natural (IndexesT (Pos + 1)); + + subtype Result_Type is String (1 .. Next - Start); + -- We need this result type to force the result to have the + -- required lower bound of 1, rather than the slice bounds. + + begin + return Result_Type (Names (Start .. Next - 1)); + end Image_Enumeration_16; + + -------------------------- + -- Image_Enumeration_32 -- + -------------------------- + + function Image_Enumeration_32 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String + is + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : Natural := Natural (IndexesT (Pos)); + Next : Natural := Natural (IndexesT (Pos + 1)); + + subtype Result_Type is String (1 .. Next - Start); + -- We need this result type to force the result to have the + -- required lower bound of 1, rather than the slice bounds. + + begin + return Result_Type (Names (Start .. Next - 1)); + end Image_Enumeration_32; + +end System.Img_Enum; diff --git a/gcc/ada/s-imgenu.ads b/gcc/ada/s-imgenu.ads new file mode 100644 index 00000000000..641fbeabf4e --- /dev/null +++ b/gcc/ada/s-imgenu.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- Enumeration_Type'Image for all enumeration types except those in package +-- Standard (where we have no opportunity to build image tables), and in +-- package System (where it is too early to start building image tables). +-- Special routines exist for the enumeration routines in these packages. + +package System.Img_Enum is +pragma Pure (Img_Enum); + + function Image_Enumeration_8 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String; + -- Used to compute Enum'Image (Str) where Enum is some enumeration type + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- is the number of enumeration literals in the type. The Indexes values + -- are the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. The value returned is the + -- desired 'Image value. + + function Image_Enumeration_16 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String; + -- Identical to Image_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Image_Enumeration_32 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String; + -- Identical to Image_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + + +end System.Img_Enum; diff --git a/gcc/ada/s-imgint.adb b/gcc/ada/s-imgint.adb new file mode 100644 index 00000000000..445f11fdf06 --- /dev/null +++ b/gcc/ada/s-imgint.adb @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ I N T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ -- +-- -- +-- 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 System.Img_Int is + + ------------------- + -- Image_Integer -- + ------------------- + + function Image_Integer (V : Integer) return String is + P : Natural; + S : String (1 .. Integer'Width); + + begin + if V >= 0 then + P := 1; + S (P) := ' '; + else + P := 0; + end if; + + Set_Image_Integer (V, S, P); + return S (1 .. P); + end Image_Integer; + + ----------------------- + -- Set_Image_Integer -- + ----------------------- + + procedure Set_Image_Integer + (V : Integer; + S : out String; + P : in out Natural) + is + procedure Set_Digits (T : Integer); + -- Set digits of absolute value of T, which is zero or negative. We work + -- with the negative of the value so that the largest negative number is + -- not a special case. + + procedure Set_Digits (T : Integer) is + begin + if T <= -10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (48 - (T rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 - T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Integer + + begin + if V >= 0 then + Set_Digits (-V); + + else + P := P + 1; + S (P) := '-'; + Set_Digits (V); + end if; + end Set_Image_Integer; + +end System.Img_Int; diff --git a/gcc/ada/s-imgint.ads b/gcc/ada/s-imgint.ads new file mode 100644 index 00000000000..5804310d458 --- /dev/null +++ b/gcc/ada/s-imgint.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- 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 contains the routines for supporting the Image attribute for +-- signed integer types up to Size Integer'Size, and also for conversion +-- operations required in Text_IO.Integer_IO for such types. + +package System.Img_Int is +pragma Pure (Img_Int); + + function Image_Integer (V : Integer) return String; + -- Computes Integer'Image (V) and returns the result + + procedure Set_Image_Integer + (V : Integer; + S : out String; + P : in out Natural); + -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e. + -- Text_IO format where Width = 0), starting at S (P + 1), updating P + -- to point to the last character stored. The caller promises that the + -- buffer is large enough and no check is made for this (Constraint_Error + -- will not be necessarily raised if this is violated since it is perfectly + -- valid to compile this unit with checks off). + +end System.Img_Int; diff --git a/gcc/ada/s-imgllb.adb b/gcc/ada/s-imgllb.adb new file mode 100644 index 00000000000..c4c419fc9fe --- /dev/null +++ b/gcc/ada/s-imgllb.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L B -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_LLB is + + --------------------------------------- + -- Set_Image_Based_Long_Long_Integer -- + --------------------------------------- + + procedure Set_Image_Based_Long_Long_Integer + (V : Long_Long_Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Based_Long_Long_Unsigned + (Long_Long_Unsigned (V), B, W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Based_Long_Long_Unsigned + (Long_Long_Unsigned (-V), B, W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Based_Long_Long_Integer; + + ---------------------------------------- + -- Set_Image_Based_Long_Long_Unsigned -- + ---------------------------------------- + + procedure Set_Image_Based_Long_Long_Unsigned + (V : Long_Long_Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + BU : constant Long_Long_Unsigned := Long_Long_Unsigned (B); + Hex : constant array + (Long_Long_Unsigned range 0 .. 15) of Character := + "0123456789ABCDEF"; + + procedure Set_Digits (T : Long_Long_Unsigned); + -- Set digits of absolute value of T + + procedure Set_Digits (T : Long_Long_Unsigned) is + begin + if T >= BU then + Set_Digits (T / BU); + P := P + 1; + S (P) := Hex (T mod BU); + else + P := P + 1; + S (P) := Hex (T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Based_Long_Long_Unsigned + + begin + + if B >= 10 then + P := P + 1; + S (P) := '1'; + end if; + + P := P + 1; + S (P) := Character'Val (Character'Pos ('0') + B mod 10); + + P := P + 1; + S (P) := '#'; + + Set_Digits (V); + + P := P + 1; + S (P) := '#'; + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := Start + W; + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Based_Long_Long_Unsigned; + +end System.Img_LLB; diff --git a/gcc/ada/s-imgllb.ads b/gcc/ada/s-imgllb.ads new file mode 100644 index 00000000000..5a83513c717 --- /dev/null +++ b/gcc/ada/s-imgllb.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L B -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image in based format of signed and +-- unsigned integers whose size > Integer'Size for use by Text_IO.Integer_IO +-- and Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_LLB is +pragma Preelaborate (Img_LLB); + + procedure Set_Image_Based_Long_Long_Integer + (V : Long_Long_Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes a leading minus sign if necessary, but no leading + -- spaces unless W is positive, in which case leading spaces are output if + -- necessary to ensure that the output string is no less than W characters + -- long. The caller promises that the buffer is large enough and no check + -- is made for this. Constraint_Error will not necessarily be raised if + -- this is violated, since it is perfectly valid to compile this unit with + -- checks off. + + procedure Set_Image_Based_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes no leading spaces unless W is positive, in which case + -- leading spaces are output if necessary to ensure that the output string + -- is no less than W characters long. The caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). + +end System.Img_LLB; diff --git a/gcc/ada/s-imglld.adb b/gcc/ada/s-imglld.adb new file mode 100644 index 00000000000..688c87c0770 --- /dev/null +++ b/gcc/ada/s-imglld.adb @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L D -- +-- -- +-- 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.Img_Dec; use System.Img_Dec; +with System.Img_LLI; use System.Img_LLI; + +package body System.Img_LLD is + + ----------------------------- + -- Image_Long_Long_Decimal -- + ----------------------------- + + function Image_Long_Long_Decimal + (V : Long_Long_Integer; + Scale : Integer) + return String + is + P : Natural := 0; + S : String (1 .. 64); + + begin + Set_Image_Long_Long_Decimal + (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); + + -- Mess around to make sure we have the objectionable space at the + -- start for positive numbers in accordance with the annoying rules! + + if S (1) /= ' ' and then S (1) /= '-' then + S (2 .. P + 1) := S (1 .. P); + S (1) := ' '; + return S (1 .. P + 1); + else + return S (1 .. P); + end if; + end Image_Long_Long_Decimal; + + --------------------------------- + -- Set_Image_Long_Long_Decimal -- + --------------------------------- + + procedure Set_Image_Long_Long_Decimal + (V : Long_Long_Integer; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + Digs : String := Image_Long_Long_Integer (V); + -- Sign and digits of decimal value + + begin + Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); + end Set_Image_Long_Long_Decimal; + +end System.Img_LLD; diff --git a/gcc/ada/s-imglld.ads b/gcc/ada/s-imglld.ads new file mode 100644 index 00000000000..0582e07c2d0 --- /dev/null +++ b/gcc/ada/s-imglld.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L D -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- Image for decimal fixed types where the size of the corresponding integer +-- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output) + +package System.Img_LLD is +pragma Preelaborate (Img_LLD); + + function Image_Long_Long_Decimal + (V : Long_Long_Integer; + Scale : Integer) + return String; + -- Compute 'Image of V, the integer value (in units of delta) of a decimal + -- type whose Scale is as given and returns the result. The image is given + -- by the rules in RM 3.5(34) for fixed-point type image functions. + + procedure Set_Image_Long_Long_Decimal + (V : Long_Long_Integer; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V, where V is the integer value (in units of delta) + -- of a decimal type with the given Scale, starting at S (P + 1), updating + -- P to point to the last character stored, the caller promises that the + -- buffer is large enough and no check is made for this. Constraint_Error + -- will not necessarily be raised if this requirement is violated, since + -- it is perfectly valid to compile this unit with checks off. The Fore, + -- Aft and Exp values can be set to any valid values for the case of use + -- by Text_IO.Decimal_IO. + +end System.Img_LLD; diff --git a/gcc/ada/s-imglli.adb b/gcc/ada/s-imglli.adb new file mode 100644 index 00000000000..571110c6735 --- /dev/null +++ b/gcc/ada/s-imglli.adb @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L I -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- 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 System.Img_LLI is + + ----------------------------- + -- Image_Long_Long_Integer -- + ----------------------------- + + function Image_Long_Long_Integer (V : Long_Long_Integer) return String is + P : Natural; + S : String (1 .. Long_Long_Integer'Width); + + begin + if V >= 0 then + P := 1; + S (P) := ' '; + else + P := 0; + end if; + + Set_Image_Long_Long_Integer (V, S, P); + return S (1 .. P); + end Image_Long_Long_Integer; + + --------------------------------- + -- Set_Image_Long_Long_Integer -- + --------------------------------- + + procedure Set_Image_Long_Long_Integer + (V : Long_Long_Integer; + S : out String; + P : in out Natural) + is + procedure Set_Digits (T : Long_Long_Integer); + -- Set digits of absolute value of T, which is zero or negative. We work + -- with the negative of the value so that the largest negative number is + -- not a special case. + + procedure Set_Digits (T : Long_Long_Integer) is + begin + if T <= -10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (48 - (T rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 - T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Long_Long_Integer + + begin + if V >= 0 then + Set_Digits (-V); + + else + P := P + 1; + S (P) := '-'; + Set_Digits (V); + end if; + + end Set_Image_Long_Long_Integer; + +end System.Img_LLI; diff --git a/gcc/ada/s-imglli.ads b/gcc/ada/s-imglli.ads new file mode 100644 index 00000000000..b927c635a10 --- /dev/null +++ b/gcc/ada/s-imglli.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- 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 contains the routines for supporting the Image attribute for +-- signed integer types larger than Size Integer'Size, and also for conversion +-- operations required in Text_IO.Integer_IO for such types. + +package System.Img_LLI is +pragma Preelaborate (Img_LLI); + + function Image_Long_Long_Integer (V : Long_Long_Integer) return String; + -- Computes Long_Long_Integer'Image (V) and returns the result. + + procedure Set_Image_Long_Long_Integer + (V : Long_Long_Integer; + S : out String; + P : in out Natural); + -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e. + -- Text_IO format where Width = 0), starting at S (P + 1), updating P + -- to point to the last character stored. The caller promises that the + -- buffer is large enough and no check is made for this (Constraint_Error + -- will not be necessarily raised if this is violated since it is perfectly + -- valid to compile this unit with checks off). + +end System.Img_LLI; diff --git a/gcc/ada/s-imgllu.adb b/gcc/ada/s-imgllu.adb new file mode 100644 index 00000000000..e5d1d487a87 --- /dev/null +++ b/gcc/ada/s-imgllu.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L U -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_LLU is + + ------------------------------ + -- Image_Long_Long_Unsigned -- + ------------------------------ + + function Image_Long_Long_Unsigned + (V : Long_Long_Unsigned) + return String + is + P : Natural; + S : String (1 .. Long_Long_Unsigned'Width); + + begin + P := 1; + S (P) := ' '; + Set_Image_Long_Long_Unsigned (V, S, P); + return S (1 .. P); + end Image_Long_Long_Unsigned; + + ----------------------- + -- Set_Image_Long_Long_Unsigned -- + ----------------------- + + procedure Set_Image_Long_Long_Unsigned + (V : Long_Long_Unsigned; + S : out String; + P : in out Natural) + is + procedure Set_Digits (T : Long_Long_Unsigned); + -- Set digits of absolute value of T + + procedure Set_Digits (T : Long_Long_Unsigned) is + begin + if T >= 10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (48 + (T rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 + T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Long_Long_Unsigned + + begin + Set_Digits (V); + + end Set_Image_Long_Long_Unsigned; + +end System.Img_LLU; diff --git a/gcc/ada/s-imgllu.ads b/gcc/ada/s-imgllu.ads new file mode 100644 index 00000000000..fed63e50c52 --- /dev/null +++ b/gcc/ada/s-imgllu.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L U -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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 contains the routines for supporting the Image attribute for +-- unsigned (modular) integer types larger than Size Unsigned'Size, and also +-- for conversion operations required in Text_IO.Modular_IO for such types. + +with System.Unsigned_Types; + +package System.Img_LLU is +pragma Pure (Img_LLU); + + function Image_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned) + return String; + -- Computes Long_Long_Unsigned'Image (V) and returns the result. + + procedure Set_Image_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + S : out String; + P : in out Natural); + -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e. + -- Text_IO format where Width = 0), starting at S (P + 1), updating P + -- to point to the last character stored. The caller promises that the + -- buffer is large enough and no check is made for this (Constraint_Error + -- will not be necessarily raised if this is violated since it is perfectly + -- valid to compile this unit with checks off). + +end System.Img_LLU; diff --git a/gcc/ada/s-imgllw.adb b/gcc/ada/s-imgllw.adb new file mode 100644 index 00000000000..89796022854 --- /dev/null +++ b/gcc/ada/s-imgllw.adb @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L W -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_LLW is + + --------------------------------------- + -- Set_Image_Width_Long_Long_Integer -- + --------------------------------------- + + procedure Set_Image_Width_Long_Long_Integer + (V : Long_Long_Integer; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Width_Long_Long_Unsigned + (Long_Long_Unsigned (V), W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Width_Long_Long_Unsigned + (Long_Long_Unsigned (-V), W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Width_Long_Long_Integer; + + ---------------------------------------- + -- Set_Image_Width_Long_Long_Unsigned -- + ---------------------------------------- + + procedure Set_Image_Width_Long_Long_Unsigned + (V : Long_Long_Unsigned; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + + procedure Set_Digits (T : Long_Long_Unsigned); + -- Set digits of absolute value of T + + procedure Set_Digits (T : Long_Long_Unsigned) is + begin + if T >= 10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (T mod 10 + Character'Pos ('0')); + else + P := P + 1; + S (P) := Character'Val (T + Character'Pos ('0')); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Width_Long_Long_Unsigned + + begin + Set_Digits (V); + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := P + (W - (P - Start)); + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Width_Long_Long_Unsigned; + +end System.Img_LLW; diff --git a/gcc/ada/s-imgllw.ads b/gcc/ada/s-imgllw.ads new file mode 100644 index 00000000000..23ebfd04d09 --- /dev/null +++ b/gcc/ada/s-imgllw.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L W -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image of signed and unsigned +-- integers whose size > Integer'Size for use by Text_IO.Integer_IO, +-- Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_LLW is +pragma Pure (Img_LLW); + + procedure Set_Image_Width_Long_Long_Integer + (V : Long_Long_Integer; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes + -- a leading minus sign if necessary, but no leading spaces unless W is + -- positive, in which case leading spaces are output if necessary to ensure + -- that the output string is no less than W characters long. The caller + -- promises that the buffer is large enough and no check is made for this. + -- Constraint_Error will not necessarily be raised if this is violated, + -- since it is perfectly valid to compile this unit with checks off. + + procedure Set_Image_Width_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes no + -- leading spaces unless W is positive, in which case leading spaces are + -- output if necessary to ensure that the output string is no less than + -- W characters long. The caller promises that the buffer is large enough + -- and no check is made for this. Constraint_Error will not necessarily be + -- raised if this is violated, since it is perfectly valid to compile this + -- unit with checks off. + +end System.Img_LLW; diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb new file mode 100644 index 00000000000..c5fdd76cbd9 --- /dev/null +++ b/gcc/ada/s-imgrea.adb @@ -0,0 +1,674 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ R E A L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.45 $ +-- -- +-- 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.Img_LLU; use System.Img_LLU; +with System.Img_Uns; use System.Img_Uns; +with System.Powten_Table; use System.Powten_Table; +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_Real is + + -- The following defines the maximum number of digits that we can convert + -- accurately. This is limited by the precision of Long_Long_Float, and + -- also by the number of digits we can hold in Long_Long_Unsigned, which + -- is the integer type we use as an intermediate for the result. + + -- We assume that in practice, the limitation will come from the digits + -- value, rather than the integer value. This is true for typical IEEE + -- implementations, and at worst, the only loss is for some precision + -- in very high precision floating-point output. + + -- Note that in the following, the "-2" accounts for the sign and one + -- extra digits, since we need the maximum number of 9's that can be + -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width + -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits, + -- but the maximum number of 9's that can be supported is 19. + + Maxdigs : constant := + Natural'Min + (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits); + + Unsdigs : constant := Unsigned'Width - 2; + -- Number of digits that can be converted using type Unsigned + -- See above for the explanation of the -2. + + Maxscaling : constant := 5000; + -- Max decimal scaling required during conversion of floating-point + -- numbers to decimal. This is used to defend against infinite + -- looping in the conversion, as can be caused by erroneous executions. + -- The largest exponent used on any current system is 2**16383, which + -- is approximately 10**4932, and the highest number of decimal digits + -- is about 35 for 128-bit floating-point formats, so 5000 leaves + -- enough room for scaling such values + + function Is_Negative (V : Long_Long_Float) return Boolean; + pragma Import (Intrinsic, Is_Negative); + + -------------------------- + -- Image_Floating_Point -- + -------------------------- + + function Image_Floating_Point + (V : Long_Long_Float; + Digs : Natural) + return String + is + P : Natural := 0; + S : String (1 .. Long_Long_Float'Width); + + begin + if not Is_Negative (V) then + S (1) := ' '; + P := 1; + end if; + + Set_Image_Real (V, S, P, 1, Digs - 1, 3); + return S (1 .. P); + end Image_Floating_Point; + + -------------------------------- + -- Image_Ordinary_Fixed_Point -- + -------------------------------- + + function Image_Ordinary_Fixed_Point + (V : Long_Long_Float; + Aft : Natural) + return String + is + P : Natural := 0; + S : String (1 .. Long_Long_Float'Width); + + begin + if V >= 0.0 then + S (1) := ' '; + P := 1; + end if; + + Set_Image_Real (V, S, P, 1, Aft, 0); + return S (1 .. P); + end Image_Ordinary_Fixed_Point; + + -------------------- + -- Set_Image_Real -- + -------------------- + + procedure Set_Image_Real + (V : Long_Long_Float; + S : out String; + P : in out Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + procedure Reset; + pragma Import (C, Reset, "__gnat_init_float"); + -- We import the floating-point processor reset routine so that we can + -- be sure the floating-point processor is properly set for conversion + -- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads). + -- This is notably need on Windows, where calls to the operating system + -- randomly reset the processor into 64-bit mode. + + NFrac : constant Natural := Natural'Max (Aft, 1); + Sign : Character; + X : aliased Long_Long_Float; + -- This is declared aliased because the expansion of X'Valid passes + -- X by access and JGNAT requires all access parameters to be aliased. + -- The Valid attribute probably needs to be handled via a different + -- expansion for JGNAT, and this use of aliased should be removed + -- once Valid is handled properly. ??? + Scale : Integer; + Expon : Integer; + + Field_Max : constant := 255; + -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last. + -- It is not worth dragging in Ada.Text_IO to pick up this value, + -- since it really should never be necessary to change it! + + Digs : String (1 .. 2 * Field_Max + 16); + -- Array used to hold digits of converted integer value. This is a + -- large enough buffer to accomodate ludicrous values of Fore and Aft. + + Ndigs : Natural; + -- Number of digits stored in Digs (and also subscript of last digit) + + procedure Adjust_Scale (S : Natural); + -- Adjusts the value in X by multiplying or dividing by a power of + -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes + -- adding 0.5 to round the result, readjusting if the rounding causes + -- the result to wander out of the range. Scale is adjusted to reflect + -- the power of ten used to divide the result (i.e. one is added to + -- the scale value for each division by 10.0, or one is subtracted + -- for each multiplication by 10.0). + + procedure Convert_Integer; + -- Takes the value in X, outputs integer digits into Digs. On return, + -- Ndigs is set to the number of digits stored. The digits are stored + -- in Digs (1 .. Ndigs), + + procedure Set (C : Character); + -- Sets character C in output buffer + + procedure Set_Blanks_And_Sign (N : Integer); + -- Sets leading blanks and minus sign if needed. N is the number of + -- positions to be filled (a minus sign is output even if N is zero + -- or negative, but for a positive value, if N is non-positive, then + -- the call has no effect). + + procedure Set_Digs (S, E : Natural); + -- Set digits S through E from Digs buffer. No effect if S > E + + procedure Set_Special_Fill (N : Natural); + -- After outputting +Inf, -Inf or NaN, this routine fills out the + -- rest of the field with * characters. The argument is the number + -- of characters output so far (either 3 or 4) + + procedure Set_Zeros (N : Integer); + -- Set N zeros, no effect if N is negative + + pragma Inline (Set); + pragma Inline (Set_Digs); + pragma Inline (Set_Zeros); + + ------------------ + -- Adjust_Scale -- + ------------------ + + procedure Adjust_Scale (S : Natural) is + Lo : Natural; + Hi : Natural; + Mid : Natural; + XP : Long_Long_Float; + + begin + -- Cases where scaling up is required + + if X < Powten (S - 1) then + + -- What we are looking for is a power of ten to multiply X by + -- so that the result lies within the required range. + + loop + XP := X * Powten (Maxpow); + exit when XP >= Powten (S - 1) or Scale < -Maxscaling; + X := XP; + Scale := Scale - Maxpow; + end loop; + + -- The following exception is only raised in case of erroneous + -- execution, where a number was considered valid but still + -- fails to scale up. One situation where this can happen is + -- when a system which is supposed to be IEEE-compliant, but + -- has been reconfigured to flush denormals to zero. + + if Scale < -Maxscaling then + raise Constraint_Error; + end if; + + -- Here we know that we must multiply by at least 10**1 and that + -- 10**Maxpow takes us too far: binary search to find right one. + + -- Because of roundoff errors, it is possible for the value + -- of XP to be just outside of the interval when Lo >= Hi. In + -- that case we adjust explicitly by a factor of 10. This + -- can only happen with a value that is very close to an + -- exact power of 10. + + Lo := 1; + Hi := Maxpow; + + loop + Mid := (Lo + Hi) / 2; + XP := X * Powten (Mid); + + if XP < Powten (S - 1) then + + if Lo >= Hi then + Mid := Mid + 1; + XP := XP * 10.0; + exit; + + else + Lo := Mid + 1; + end if; + + elsif XP >= Powten (S) then + + if Lo >= Hi then + Mid := Mid - 1; + XP := XP / 10.0; + exit; + + else + Hi := Mid - 1; + end if; + + else + exit; + end if; + end loop; + + X := XP; + Scale := Scale - Mid; + + -- Cases where scaling down is required + + elsif X >= Powten (S) then + + -- What we are looking for is a power of ten to divide X by + -- so that the result lies within the required range. + + loop + XP := X / Powten (Maxpow); + exit when XP < Powten (S) or Scale > Maxscaling; + X := XP; + Scale := Scale + Maxpow; + end loop; + + -- The following exception is only raised in case of erroneous + -- execution, where a number was considered valid but still + -- fails to scale up. One situation where this can happen is + -- when a system which is supposed to be IEEE-compliant, but + -- has been reconfigured to flush denormals to zero. + + if Scale > Maxscaling then + raise Constraint_Error; + end if; + + -- Here we know that we must divide by at least 10**1 and that + -- 10**Maxpow takes us too far, binary search to find right one. + + Lo := 1; + Hi := Maxpow; + + loop + Mid := (Lo + Hi) / 2; + XP := X / Powten (Mid); + + if XP < Powten (S - 1) then + + if Lo >= Hi then + XP := XP * 10.0; + Mid := Mid - 1; + exit; + + else + Hi := Mid - 1; + end if; + + elsif XP >= Powten (S) then + + if Lo >= Hi then + XP := XP / 10.0; + Mid := Mid + 1; + exit; + + else + Lo := Mid + 1; + end if; + + else + exit; + end if; + end loop; + + X := XP; + Scale := Scale + Mid; + + -- Here we are already scaled right + + else + null; + end if; + + -- Round, readjusting scale if needed. Note that if a readjustment + -- occurs, then it is never necessary to round again, because there + -- is no possibility of such a second rounding causing a change. + + X := X + 0.5; + + if X >= Powten (S) then + X := X / 10.0; + Scale := Scale + 1; + end if; + + end Adjust_Scale; + + --------------------- + -- Convert_Integer -- + --------------------- + + procedure Convert_Integer is + begin + -- Use Unsigned routine if possible, since on many machines it will + -- be significantly more efficient than the Long_Long_Unsigned one. + + if X < Powten (Unsdigs) then + Ndigs := 0; + Set_Image_Unsigned + (Unsigned (Long_Long_Float'Truncation (X)), + Digs, Ndigs); + + -- But if we want more digits than fit in Unsigned, we have to use + -- the Long_Long_Unsigned routine after all. + + else + Ndigs := 0; + Set_Image_Long_Long_Unsigned + (Long_Long_Unsigned (Long_Long_Float'Truncation (X)), + Digs, Ndigs); + end if; + end Convert_Integer; + + --------- + -- Set -- + --------- + + procedure Set (C : Character) is + begin + P := P + 1; + S (P) := C; + end Set; + + ------------------------- + -- Set_Blanks_And_Sign -- + ------------------------- + + procedure Set_Blanks_And_Sign (N : Integer) is + begin + if Sign = '-' then + for J in 1 .. N - 1 loop + Set (' '); + end loop; + + Set ('-'); + + else + for J in 1 .. N loop + Set (' '); + end loop; + end if; + end Set_Blanks_And_Sign; + + -------------- + -- Set_Digs -- + -------------- + + procedure Set_Digs (S, E : Natural) is + begin + for J in S .. E loop + Set (Digs (J)); + end loop; + end Set_Digs; + + ---------------------- + -- Set_Special_Fill -- + ---------------------- + + procedure Set_Special_Fill (N : Natural) is + F : Natural; + + begin + F := Fore + 1 + Aft - N; + + if Exp /= 0 then + F := F + Exp + 1; + end if; + + for J in 1 .. F loop + Set ('*'); + end loop; + end Set_Special_Fill; + + --------------- + -- Set_Zeros -- + --------------- + + procedure Set_Zeros (N : Integer) is + begin + for J in 1 .. N loop + Set ('0'); + end loop; + end Set_Zeros; + + -- Start of processing for Set_Image_Real + + begin + Reset; + Scale := 0; + + -- Positive values + + if V > 0.0 then + X := V; + Sign := '+'; + + -- Negative values + + elsif V < 0.0 then + X := -V; + Sign := '-'; + + -- Zero values + + elsif V = 0.0 then + if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then + Sign := '-'; + else + Sign := '+'; + end if; + + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + Set ('.'); + Set_Zeros (NFrac); + + if Exp /= 0 then + Set ('E'); + Set ('+'); + Set_Zeros (Natural'Max (1, Exp - 1)); + end if; + + return; + end if; + + -- Deal with invalid values + + if not X'Valid then + + -- Note that we're taking our chances here, as X might be + -- an invalid bit pattern resulting from erroneous execution + -- (caused by using uninitialized variables for example). + + -- No matter what, we'll at least get reasonable behaviour, + -- converting to infinity or some other value, or causing an + -- exception to be raised is fine. + + -- If the following test succeeds, then we definitely have + -- an infinite value, so we print Inf. + + if X > Long_Long_Float'Last then + Set (Sign); + Set ('I'); + Set ('n'); + Set ('f'); + Set_Special_Fill (4); + + -- In all other cases we print NaN + + else + Set ('N'); + Set ('a'); + Set ('N'); + Set_Special_Fill (3); + end if; + + return; + + -- Case of non-zero value with Exp = 0 + + elsif Exp = 0 then + + -- First step is to multiply by 10 ** Nfrac to get an integer + -- value to be output, an then add 0.5 to round the result. + + declare + NF : Natural := NFrac; + + begin + loop + -- If we are larger than Powten (Maxdigs) now, then + -- we have too many significant digits, and we have + -- not even finished multiplying by NFrac (NF shows + -- the number of unaccounted-for digits). + + if X >= Powten (Maxdigs) then + + -- In this situation, we only to generate a reasonable + -- number of significant digits, and then zeroes after. + -- So first we rescale to get: + + -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs + + -- and then convert the resulting integer + + Adjust_Scale (Maxdigs); + Convert_Integer; + + -- If that caused rescaling, then add zeros to the end + -- of the number to account for this scaling. Also add + -- zeroes to account for the undone multiplications + + for J in 1 .. Scale + NF loop + Ndigs := Ndigs + 1; + Digs (Ndigs) := '0'; + end loop; + + exit; + + -- If multiplication is complete, then convert the resulting + -- integer after rounding (note that X is non-negative) + + elsif NF = 0 then + X := X + 0.5; + Convert_Integer; + exit; + + -- Otherwise we can go ahead with the multiplication. If it + -- can be done in one step, then do it in one step. + + elsif NF < Maxpow then + X := X * Powten (NF); + NF := 0; + + -- If it cannot be done in one step, then do partial scaling + + else + X := X * Powten (Maxpow); + NF := NF - Maxpow; + end if; + end loop; + end; + + -- If number of available digits is less or equal to NFrac, + -- then we need an extra zero before the decimal point. + + if Ndigs <= NFrac then + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + Set ('.'); + Set_Zeros (NFrac - Ndigs); + Set_Digs (1, Ndigs); + + -- Normal case with some digits before the decimal point + + else + Set_Blanks_And_Sign (Fore - (Ndigs - NFrac)); + Set_Digs (1, Ndigs - NFrac); + Set ('.'); + Set_Digs (Ndigs - NFrac + 1, Ndigs); + end if; + + -- Case of non-zero value with non-zero Exp value + + else + -- If NFrac is less than Maxdigs, then all the fraction digits are + -- significant, so we can scale the resulting integer accordingly. + + if NFrac < Maxdigs then + Adjust_Scale (NFrac + 1); + Convert_Integer; + + -- Otherwise, we get the maximum number of digits available + + else + Adjust_Scale (Maxdigs); + Convert_Integer; + + for J in 1 .. NFrac - Maxdigs + 1 loop + Ndigs := Ndigs + 1; + Digs (Ndigs) := '0'; + Scale := Scale - 1; + end loop; + end if; + + Set_Blanks_And_Sign (Fore - 1); + Set (Digs (1)); + Set ('.'); + Set_Digs (2, Ndigs); + + -- The exponent is the scaling factor adjusted for the digits + -- that we output after the decimal point, since these were + -- included in the scaled digits that we output. + + Expon := Scale + NFrac; + + Set ('E'); + Ndigs := 0; + + if Expon >= 0 then + Set ('+'); + Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs); + else + Set ('-'); + Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs); + end if; + + Set_Zeros (Exp - Ndigs - 1); + Set_Digs (1, Ndigs); + end if; + + end Set_Image_Real; + +end System.Img_Real; diff --git a/gcc/ada/s-imgrea.ads b/gcc/ada/s-imgrea.ads new file mode 100644 index 00000000000..234577b965a --- /dev/null +++ b/gcc/ada/s-imgrea.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ R E A L -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Image for fixed and float types (also used for Float_IO/Fixed_IO output) + +package System.Img_Real is +pragma Preelaborate (Img_Real); + + function Image_Ordinary_Fixed_Point + (V : Long_Long_Float; + Aft : Natural) + return String; + -- Computes the image of V and returns the result according to the rules + -- for image for fixed-point types (RM 3.5(34)), where Aft is the value of + -- the Aft attribute for the fixed-point type. This function is used only + -- for ordinary fixed point (see package System.Img_Dec for handling of + -- decimal fixed-point). + + function Image_Floating_Point + (V : Long_Long_Float; + Digs : Natural) + return String; + -- Computes the image of V and returns the result according to the rules + -- for image for foating-point types (RM 3.5(33)), where Digs is the value + -- of the Digits attribute for the floating-point type. + + procedure Set_Image_Real + (V : Long_Long_Float; + S : out String; + P : in out Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V starting at S (P + 1), updating P to point to the + -- last character stored, the caller promises that the buffer is large + -- enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). The Fore, Aft and Exp values + -- can be set to any valid values for the case of use from Text_IO. + +end System.Img_Real; diff --git a/gcc/ada/s-imguns.adb b/gcc/ada/s-imguns.adb new file mode 100644 index 00000000000..2f4451df041 --- /dev/null +++ b/gcc/ada/s-imguns.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ U N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_Uns is + + -------------------- + -- Image_Unsigned -- + -------------------- + + function Image_Unsigned + (V : Unsigned) + return String + is + P : Natural; + S : String (1 .. Unsigned'Width); + + begin + P := 1; + S (P) := ' '; + Set_Image_Unsigned (V, S, P); + return S (1 .. P); + end Image_Unsigned; + + ------------------------ + -- Set_Image_Unsigned -- + ------------------------ + + procedure Set_Image_Unsigned + (V : Unsigned; + S : out String; + P : in out Natural) + is + procedure Set_Digits (T : Unsigned); + -- Set decimal digits of value of T + + procedure Set_Digits (T : Unsigned) is + begin + if T >= 10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (48 + (T rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 + T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Unsigned + + begin + Set_Digits (V); + + end Set_Image_Unsigned; + +end System.Img_Uns; diff --git a/gcc/ada/s-imguns.ads b/gcc/ada/s-imguns.ads new file mode 100644 index 00000000000..073e44e69d1 --- /dev/null +++ b/gcc/ada/s-imguns.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ U N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- 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 contains the routines for supporting the Image attribute for +-- modular integer types up to Size Modular'Size, and also for conversion +-- operations required in Text_IO.Modular_IO for such types. + +with System.Unsigned_Types; + +package System.Img_Uns is +pragma Pure (Img_Uns); + + function Image_Unsigned + (V : System.Unsigned_Types.Unsigned) + return String; + -- Computes Unsigned'Image (V) and returns the result. + + procedure Set_Image_Unsigned + (V : System.Unsigned_Types.Unsigned; + S : out String; + P : in out Natural); + -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e. + -- Text_IO format where Width = 0), starting at S (P + 1), updating P + -- to point to the last character stored. The caller promises that the + -- buffer is large enough and no check is made for this (Constraint_Error + -- will not be necessarily raised if this is violated since it is perfectly + -- valid to compile this unit with checks off). + +end System.Img_Uns; diff --git a/gcc/ada/s-imgwch.adb b/gcc/ada/s-imgwch.adb new file mode 100644 index 00000000000..487889b5d07 --- /dev/null +++ b/gcc/ada/s-imgwch.adb @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.15 $ -- +-- -- +-- 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 System.Img_Char; use System.Img_Char; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body System.Img_WChar is + + -------------------------- + -- Image_Wide_Character -- + -------------------------- + + function Image_Wide_Character + (V : Wide_Character; + EM : WC_Encoding_Method) + return String + is + Val : constant Natural := Wide_Character'Pos (V); + WS : Wide_String (1 .. 3); + + begin + -- If in range of standard character, use standard character routine + + if Val < 16#80# + or else (Val <= 16#FF# + and then EM not in WC_Upper_Half_Encoding_Method) + then + return Image_Character (Character'Val (Val)); + + -- if the value is one of the last two characters in the type, use + -- their language-defined names (3.5.2(3)). + + elsif Val = 16#FFFE# then + return "FFFE"; + + elsif Val = 16#FFFF# then + return "FFFF"; + + -- Otherwise return an appropriate escape sequence (i.e. one matching + -- the convention implemented by Scn.Wide_Char). The easiest thing is + -- to build a wide string for the result, and then use the Wide_Value + -- function to build the resulting String. + + else + WS (1) := '''; + WS (2) := V; + WS (3) := '''; + + return Wide_String_To_String (WS, EM); + end if; + + end Image_Wide_Character; + +end System.Img_WChar; diff --git a/gcc/ada/s-imgwch.ads b/gcc/ada/s-imgwch.ads new file mode 100644 index 00000000000..693d1fc91e0 --- /dev/null +++ b/gcc/ada/s-imgwch.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W C H A R -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Wide_Character'Image + +with System.WCh_Con; + +package System.Img_WChar is +pragma Pure (Img_WChar); + + function Image_Wide_Character + (V : Wide_Character; + EM : System.WCh_Con.WC_Encoding_Method) + return String; + -- Computes Wode_Character'Image (V) and returns the computed result, + -- The argument EM is a constant representing the encoding method in use. + -- The encoding method used is guaranteed to be consistent across a + -- given program execution and to correspond to the method used in the + -- source programs. + +end System.Img_WChar; diff --git a/gcc/ada/s-imgwiu.adb b/gcc/ada/s-imgwiu.adb new file mode 100644 index 00000000000..7c1c847f314 --- /dev/null +++ b/gcc/ada/s-imgwiu.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W I U -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_WIU is + + ----------------------------- + -- Set_Image_Width_Integer -- + ----------------------------- + + procedure Set_Image_Width_Integer + (V : Integer; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Width_Unsigned (Unsigned (V), W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Width_Unsigned (Unsigned (-V), W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Width_Integer; + + ------------------------------ + -- Set_Image_Width_Unsigned -- + ------------------------------ + + procedure Set_Image_Width_Unsigned + (V : Unsigned; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + + procedure Set_Digits (T : Unsigned); + -- Set digits of absolute value of T + + procedure Set_Digits (T : Unsigned) is + begin + if T >= 10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (T mod 10 + Character'Pos ('0')); + else + P := P + 1; + S (P) := Character'Val (T + Character'Pos ('0')); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Width_Unsigned + + begin + Set_Digits (V); + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := P + (W - (P - Start)); + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Width_Unsigned; + +end System.Img_WIU; diff --git a/gcc/ada/s-imgwiu.ads b/gcc/ada/s-imgwiu.ads new file mode 100644 index 00000000000..5a9d2f465e2 --- /dev/null +++ b/gcc/ada/s-imgwiu.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W I U -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image of signed and unsigned +-- integers whose size <= Integer'Size for use by Text_IO.Integer_IO +-- and Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_WIU is +pragma Pure (Img_WIU); + + procedure Set_Image_Width_Integer + (V : Integer; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes + -- a leading minus sign if necessary, but no leading spaces unless W is + -- positive, in which case leading spaces are output if necessary to ensure + -- that the output string is no less than W characters long. The caller + -- promises that the buffer is large enough and no check is made for this. + -- Constraint_Error will not necessarily be raised if this is violated, + -- since it is perfectly valid to compile this unit with checks off. + + procedure Set_Image_Width_Unsigned + (V : System.Unsigned_Types.Unsigned; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes no + -- leading spaces unless W is positive, in which case leading spaces are + -- output if necessary to ensure that the output string is no less than + -- W characters long. The caller promises that the buffer is large enough + -- and no check is made for this. Constraint_Error will not necessarily be + -- raised if this is violated, since it is perfectly valid to compile this + -- unit with checks off. + +end System.Img_WIU; diff --git a/gcc/ada/s-inmaop.ads b/gcc/ada/s-inmaop.ads new file mode 100644 index 00000000000..173c169331b --- /dev/null +++ b/gcc/ada/s-inmaop.ads @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- +-- O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package System.Interrupt_Management.Operations is + + procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID); + -- Mask the calling thread for the interrupt + pragma Inline (Thread_Block_Interrupt); + + procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID); + -- Unmask the calling thread for the interrupt + pragma Inline (Thread_Unblock_Interrupt); + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask); + -- Set the interrupt mask of the calling thread + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask); + -- Set the interrupt mask of the calling thread while returning the + -- previous Mask. + pragma Inline (Set_Interrupt_Mask); + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask); + -- Get the interrupt mask of the calling thread + pragma Inline (Get_Interrupt_Mask); + + function Interrupt_Wait (Mask : access Interrupt_Mask) return Interrupt_ID; + -- Wait for the interrupts specified in Mask and return + -- the interrupt received. Upon error it return 0. + pragma Inline (Interrupt_Wait); + + procedure Install_Default_Action (Interrupt : Interrupt_ID); + -- Set the sigaction of the Interrupt to default (SIG_DFL). + pragma Inline (Install_Default_Action); + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID); + -- Set the sigaction of the Interrupt to ignore (SIG_IGN). + pragma Inline (Install_Ignore_Action); + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask); + -- Get a Interrupt_Mask with all the interrupt masked + pragma Inline (Fill_Interrupt_Mask); + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask); + -- Get a Interrupt_Mask with all the interrupt unmasked + pragma Inline (Empty_Interrupt_Mask); + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID); + -- Mask the given interrupt in the Interrupt_Mask + pragma Inline (Add_To_Interrupt_Mask); + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID); + -- Unmask the given interrupt in the Interrupt_Mask + pragma Inline (Delete_From_Interrupt_Mask); + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean; + -- See if a given interrupt is masked in the Interrupt_Mask + pragma Inline (Is_Member); + + procedure Copy_Interrupt_Mask (X : out Interrupt_Mask; Y : Interrupt_Mask); + -- Assigment needed for limited private type Interrupt_Mask. + pragma Inline (Copy_Interrupt_Mask); + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID); + -- raise an Interrupt process-level + pragma Inline (Interrupt_Self_Process); + + -- The following objects serve as constants, but are initialized + -- in the body to aid portability. These actually belong to the + -- System.Interrupt_Management but since Interrupt_Mask is a + -- private type we can not have them declared there. + + Environment_Mask : aliased Interrupt_Mask; + -- This mask represents the mask of Environment task when this package + -- is being elaborated, except the signals being + -- forced to be unmasked by RTS (items in Keep_Unmasked) + + All_Tasks_Mask : aliased Interrupt_Mask; + -- This is the mask of all tasks created in RTS. Only one task in RTS + -- is responsible for masking/unmasking signals (see s-interr.adb). + +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb new file mode 100644 index 00000000000..03db2ff1512 --- /dev/null +++ b/gcc/ada/s-interr.adb @@ -0,0 +1,1572 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.36 $ +-- -- +-- Copyright (C) 1991-2001 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Invariants: + +-- All user-handleable interrupts are masked at all times in all +-- tasks/threads except possibly for the Interrupt_Manager task. + +-- When a user task wants to have the effect of masking/unmasking an +-- interrupt, it must call Block_Interrupt/Unblock_Interrupt, which +-- will have the effect of unmasking/masking the interrupt in the +-- Interrupt_Manager task. + +-- Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any +-- other low-level interface that changes the interrupt action or +-- interrupt mask needs a careful thought. +-- One may acheive the effect of system calls first masking RTS blocked +-- (by calling Block_Interrupt) for the interrupt under consideration. +-- This will make all the tasks in RTS blocked for the Interrupt. + +-- Once we associate a Server_Task with an interrupt, the task never +-- goes away, and we never remove the association. + +-- There is no more than one interrupt per Server_Task and no more than +-- one Server_Task per interrupt. + +-- Within this package, the lock L is used to protect the various status +-- tables. If there is a Server_Task associated with an interrupt, we use +-- the per-task lock of the Server_Task instead so that we protect the +-- status between Interrupt_Manager and Server_Task. Protection among +-- service requests are done using User Request to Interrupt_Manager +-- rendezvous. + +with Ada.Task_Identification; +-- used for Task_ID type + +with Ada.Exceptions; +-- used for Raise_Exception + +with System.Task_Primitives; +-- used for RTS_Lock +-- Self + +with System.Interrupt_Management; +-- used for Reserve +-- Interrupt_ID +-- Interrupt_Mask +-- Abort_Task_Interrupt + +with System.Interrupt_Management.Operations; +-- used for Thread_Block_Interrupt +-- Thread_Unblock_Interrupt +-- Install_Default_Action +-- Install_Ignore_Action +-- Copy_Interrupt_Mask +-- Set_Interrupt_Mask +-- Empty_Interrupt_Mask +-- Fill_Interrupt_Mask +-- Add_To_Interrupt_Mask +-- Delete_From_Interrupt_Mask +-- Interrupt_Wait +-- Interrupt_Self_Process +-- Get_Interrupt_Mask +-- Set_Interrupt_Mask +-- IS_Member +-- Environment_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Error_Reporting; +-- used for Shutdown + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock +-- Abort +-- Wakeup_Task +-- Sleep +-- Initialize_Lock + +with System.Task_Primitives.Interrupt_Operations; +-- used for Set_Interrupt_ID + +with System.Storage_Elements; +-- used for To_Address +-- To_Integer +-- Integer_Address + +with System.Tasking; +-- used for Task_ID +-- Task_Entry_Index +-- Null_Task +-- Self +-- Interrupt_Manager_ID + +with System.Tasking.Utilities; +-- used for Make_Independent + +with System.Tasking.Rendezvous; +-- used for Call_Simple +pragma Elaborate_All (System.Tasking.Rendezvous); + +with System.Tasking.Initialization; +-- used for Defer_Abort +-- Undefer_Abort + +with Unchecked_Conversion; + +package body System.Interrupts is + + use Tasking; + use System.Error_Reporting; + use Ada.Exceptions; + + package PRI renames System.Task_Primitives; + package POP renames System.Task_Primitives.Operations; + package PIO renames System.Task_Primitives.Interrupt_Operations; + package IMNG renames System.Interrupt_Management; + package IMOP renames System.Interrupt_Management.Operations; + + function To_System is new Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_ID); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Utilities performs calls to this task + -- with low-level constructs. Do not change this spec without synchro- + -- nizing it. + + task Interrupt_Manager is + entry Initialize (Mask : IMNG.Interrupt_Mask); + + entry Attach_Handler + (New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean; + Restoration : in Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean); + + entry Detach_Handler + (Interrupt : in Interrupt_ID; + Static : in Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + entry Detach_Interrupt_Entries (T : Task_ID); + + entry Block_Interrupt (Interrupt : Interrupt_ID); + + entry Unblock_Interrupt (Interrupt : Interrupt_ID); + + entry Ignore_Interrupt (Interrupt : Interrupt_ID); + + entry Unignore_Interrupt (Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Interrupt_Manager; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Priority (System.Interrupt_Priority'Last); + end Server_Task; + + type Server_Task_Access is access Server_Task; + + -------------------------------- + -- Local Types and Variables -- + -------------------------------- + + type Entry_Assoc is record + T : Task_ID; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt. A handler is a Static one if + -- it is specified through the pragma Attach_Handler. + -- Attach_Handler. Otherwise, not static) + + User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt + + Blocked : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Volatile_Components (Blocked); + -- True iff the corresponding interrupt is blocked in the process level + + Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Volatile_Components (Ignored); + -- True iff the corresponding interrupt is blocked in the process level + + Last_Unblocker : + array (Interrupt_ID'Range) of Task_ID := (others => Null_Task); + pragma Volatile_Components (Last_Unblocker); + -- Holds the ID of the last Task which Unblocked this Interrupt. + -- It contains Null_Task if no tasks have ever requested the + -- Unblocking operation or the Interrupt is currently Blocked. + + Server_ID : array (Interrupt_ID'Range) of Task_ID := + (others => Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_ID of the Server_Task for each interrupt. + -- Task_ID is needed to accomplish locking per Interrupt base. Also + -- is needed to decide whether to create a new Server_Task. + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Access_Hold : Server_Task_Access; + -- variable used to allocate Server_Task using "new". + + L : aliased PRI.RTS_Lock; + -- L protects contents in tables above corresponding to interrupts + -- for which Server_ID (T) = null. + -- + -- If Server_ID (T) /= null then protection is via + -- per-task (TCB) lock of Server_ID (T). + -- + -- For deadlock prevention, L should not be locked after + -- any other lock is held, hence we use PO_Level which is the highest + -- lock level for error checking. + + Task_Lock : array (Interrupt_ID'Range) of Boolean := (others => False); + -- Boolean flags to give matching Locking and Unlocking. See the comments + -- in Lock_Interrupt. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Lock_Interrupt + (Self_ID : Task_ID; + Interrupt : Interrupt_ID); + -- protect the tables using L or per-task lock. Set the Boolean + -- value Task_Lock if the lock is made using per-task lock. + -- This information is needed so that Unlock_Interrupt + -- performs unlocking on the same lock. The situation we are preventing + -- is, for example, when Attach_Handler is called for the first time + -- we lock L and create an Server_Task. For a matching unlocking, if we + -- rely on the fact that there is a Server_Task, we will unlock the + -- per-task lock. + + procedure Unlock_Interrupt + (Self_ID : Task_ID; + Interrupt : Interrupt_ID); + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- ??? spec needs comments + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (ie. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to + -- bind an interrupt to which an Entry or a Procedure is + -- already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Block_Interrupt (Interrupt); + end Block_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) + return Parameterless_Handler + is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + -- ??? Since Parameterless_Handler is not Atomic, the + -- current implementation is wrong. We need a new service in + -- Interrupt_Manager to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : in Interrupt_ID; + Static : in Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Detach_Handler (Interrupt, Static); + + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_ID) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (ie. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + + end Exchange_Handler; + + ---------------- + -- Finalize -- + ---------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + if not Interrupt_Manager'Terminated then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean is + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Ignore_Interrupt (Interrupt); + end Ignore_Interrupt; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : in New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Blocked (Interrupt); + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Ignored (Interrupt); + end Is_Ignored; + + ------------------- + -- Is_Registered -- + ------------------- + + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while (Ptr /= null) loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + -------------------- + -- Lock_Interrupt -- + -------------------- + + -- ????? + + -- This package has been modified several times. + -- Do we still need this fancy locking scheme, now that more operations + -- are entries of the interrupt manager task? + + -- ????? + + -- More likely, we will need to convert one or more entry calls to + -- protected operations, because presently we are violating locking order + -- rules by calling a task entry from within the runtime system. + + procedure Lock_Interrupt + (Self_ID : Task_ID; + Interrupt : Interrupt_ID) + is + begin + Initialization.Defer_Abort (Self_ID); + + POP.Write_Lock (L'Access); + + if Task_Lock (Interrupt) then + + -- We need to use per-task lock. + + POP.Unlock (L'Access); + POP.Write_Lock (Server_ID (Interrupt)); + + -- Rely on the fact that once Server_ID is set to a non-null + -- value it will never be set back to null. + + elsif Server_ID (Interrupt) /= Null_Task then + + -- We need to use per-task lock. + + Task_Lock (Interrupt) := True; + POP.Unlock (L'Access); + POP.Write_Lock (Server_ID (Interrupt)); + end if; + end Lock_Interrupt; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + --------------------------------- + -- Register_Interrupt_Handler -- + --------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + + begin + -- This routine registers the Handler as usable for Dynamic + -- Interrupt Handler. Routines attaching and detaching Handler + -- dynamically should first consult if the Handler is rgistered. + -- A Program Error should be raised if it is not registered. + + -- The pragma Interrupt_Handler can only appear in the library + -- level PO definition and instantiation. Therefore, we do not need + -- to implement Unregistering operation. Neither we need to + -- protect the queue structure using a Lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Unblock_Interrupt (Interrupt); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) + return System.Tasking.Task_ID + is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Last_Unblocker (Interrupt); + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Unignore_Interrupt (Interrupt); + end Unignore_Interrupt; + + ---------------------- + -- Unlock_Interrupt -- + ---------------------- + + procedure Unlock_Interrupt + (Self_ID : Task_ID; + Interrupt : Interrupt_ID) + is + begin + if Task_Lock (Interrupt) then + POP.Unlock (Server_ID (Interrupt)); + else + POP.Unlock (L'Access); + end if; + + Initialization.Undefer_Abort (Self_ID); + end Unlock_Interrupt; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + ---------------------- + -- Local Variables -- + ---------------------- + + Intwait_Mask : aliased IMNG.Interrupt_Mask; + Ret_Interrupt : Interrupt_ID; + Old_Mask : aliased IMNG.Interrupt_Mask; + Self_ID : Task_ID := POP.Self; + + --------------------- + -- Local Routines -- + --------------------- + + procedure Bind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if the Interrupt is blocked. + -- Otherwise, we have to interrupt Server_Task for status change through + -- Wakeup interrupt. + + procedure Unbind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if the Interrupt is blocked. + -- Otherwise, we have to interrupt Server_Task for status change + -- through abort interrupt. + + -- Following two procedure are named Unprotected... in order to + -- indicate that Lock/Unlock_Interrupt operations are needed around. + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean; + Restoration : in Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : in Interrupt_ID; + Static : in Boolean); + + ------------------ + -- Bind_Handler -- + ------------------ + + procedure Bind_Handler (Interrupt : Interrupt_ID) is + begin + if not Blocked (Interrupt) then + + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt and the actuall delivery of the + -- Interrupt will be caught using "sigwait" by the + -- corresponding Server_Task. + + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + -- We have installed a Handler or an Entry before we called + -- this procedure. If the Handler Task is waiting to be awakened, + -- do it here. Otherwise, the interrupt will be discarded. + + POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); + end if; + end Bind_Handler; + + -------------------- + -- Unbind_Handler -- + -------------------- + + procedure Unbind_Handler (Interrupt : Interrupt_ID) is + begin + if not Blocked (Interrupt) then + + -- Currently, there is a Handler or an Entry attached and + -- corresponding Server_Task is waiting on "sigwait." + -- We have to wake up the Server_Task and make it + -- wait on condition variable by sending an + -- Abort_Task_Interrupt + + POP.Abort_Task (Server_ID (Interrupt)); + + -- Make sure corresponding Server_Task is out of its own + -- sigwait state. + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + + pragma Assert + (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Unmake the Interrupt for this task in order to allow default + -- action again. + + IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + else + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + end if; + + end Unbind_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : in Interrupt_ID; + Static : in Boolean) + is + Old_Handler : Parameterless_Handler; + + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- In case we have an Interrupt Entry installed. + -- raise a program error. (propagate it to the caller). + + Unlock_Interrupt (Self_ID, Interrupt); + Raise_Exception (Program_Error'Identity, + "An interrupt entry is already installed"); + end if; + + -- Note : Static = True will pass the following check. That is the + -- case when we want to detach a handler regardless of the static + -- status of the current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + + -- Tries to detach a static Interrupt Handler. + -- raise a program error. + + Unlock_Interrupt (Self_ID, Interrupt); + Raise_Exception (Program_Error'Identity, + "Trying to detach a static Interrupt Handler"); + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + + end Unprotected_Detach_Handler; + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean; + Restoration : in Boolean := False) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + + -- In case we have an Interrupt Entry already installed. + -- raise a program error. (propagate it to the caller). + + Unlock_Interrupt (Self_ID, Interrupt); + Raise_Exception (Program_Error'Identity, + "An interrupt is already installed"); + end if; + + -- Note : A null handler with Static = True will + -- pass the following check. That is the case when we want to + -- Detach a handler regardless of the Static status + -- of the current_Handler. + -- We don't check anything if Restoration is True, since we + -- may be detaching a static handler to restore a dynamic one. + + if not Restoration and then not Static + + -- Tries to overwrite a static Interrupt Handler with a + -- dynamic Handler + + and then (User_Handler (Interrupt).Static + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + Unlock_Interrupt (Self_ID, Interrupt); + Raise_Exception (Program_Error'Identity, + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"); + end if; + + -- The interrupt should no longer be ingnored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler. + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. + + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + + Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); + end if; + + if (New_Handler = null) then + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + + return; + end if; + + if Old_Handler = null then + Bind_Handler (Interrupt); + end if; + + end Unprotected_Exchange_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Environmen task gets its own interrupt mask, saves it, + -- and then masks all interrupts except the Keep_Unmasked set. + + -- During rendezvous, the Interrupt_Manager receives the old + -- interrupt mask of the environment task, and sets its own + -- interrupt mask to that value. + + -- The environment task will call the entry of Interrupt_Manager some + -- during elaboration of the body of this package. + + accept Initialize (Mask : IMNG.Interrupt_Mask) do + declare + The_Mask : aliased IMNG.Interrupt_Mask; + + begin + IMOP.Copy_Interrupt_Mask (The_Mask, Mask); + IMOP.Set_Interrupt_Mask (The_Mask'Access); + end; + end Initialize; + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked + -- in all tasks. We mask the Interrupt in this particular task + -- so that "sigwait" is possible to catch an explicitely sent + -- Abort_Task_Interrupt from the Server_Tasks. + + -- This sigwaiting is needed so that we make sure a Server_Task is + -- out of its own sigwait state. This extra synchronization is + -- necessary to prevent following senarios. + + -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the + -- Server_Task then changes its own interrupt mask (OS level). + -- If an interrupt (corresponding to the Server_Task) arrives + -- in the nean time we have the Interrupt_Manager umnasked and + -- the Server_Task waiting on sigwait. + + -- 2) For unbinding handler, we install a default action in the + -- Interrupt_Manager. POSIX.1c states that the result of using + -- "sigwait" and "sigaction" simaltaneously on the same interrupt + -- is undefined. Therefore, we need to be informed from the + -- Server_Task of the fact that the Server_Task is out of its + -- sigwait stage. + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); + IMOP.Thread_Block_Interrupt + (IMNG.Abort_Task_Interrupt); + + loop + -- A block is needed to absorb Program_Error exception + + declare + Old_Handler : Parameterless_Handler; + + begin + select + + accept Attach_Handler + (New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean; + Restoration : in Boolean := False) + do + Lock_Interrupt (Self_ID, Interrupt); + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + Unlock_Interrupt (Self_ID, Interrupt); + end Attach_Handler; + + or accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : in Parameterless_Handler; + Interrupt : in Interrupt_ID; + Static : in Boolean) + do + Lock_Interrupt (Self_ID, Interrupt); + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + Unlock_Interrupt (Self_ID, Interrupt); + end Exchange_Handler; + + or accept Detach_Handler + (Interrupt : in Interrupt_ID; + Static : in Boolean) + do + Lock_Interrupt (Self_ID, Interrupt); + Unprotected_Detach_Handler (Interrupt, Static); + Unlock_Interrupt (Self_ID, Interrupt); + end Detach_Handler; + + or accept Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + Lock_Interrupt (Self_ID, Interrupt); + + -- if there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + Unlock_Interrupt (Self_ID, Interrupt); + Raise_Exception (Program_Error'Identity, + "A binding for this interrupt is already present"); + end if; + + -- The interrupt should no longer be ingnored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E); + + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task terminates + -- the binding can be cleaned. The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + + -- When a new Server_Task is created, it should have its + -- signal mask set to the All_Tasks_Mask. + + IMOP.Set_Interrupt_Mask + (IMOP.All_Tasks_Mask'Access, Old_Mask'Access); + Access_Hold := new Server_Task (Interrupt); + IMOP.Set_Interrupt_Mask (Old_Mask'Access); + Server_ID (Interrupt) := + To_System (Access_Hold.all'Identity); + end if; + + Bind_Handler (Interrupt); + Unlock_Interrupt (Self_ID, Interrupt); + end Bind_Interrupt_To_Entry; + + or accept Detach_Interrupt_Entries (T : Task_ID) + do + for I in Interrupt_ID'Range loop + if not Is_Reserved (I) then + Lock_Interrupt (Self_ID, I); + + if User_Entry (I).T = T then + + -- The interrupt should no longer be ingnored if + -- it was ever ignored. + + Ignored (I) := False; + User_Entry (I) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (I); + end if; + + Unlock_Interrupt (Self_ID, I); + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached. + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + + or accept Block_Interrupt (Interrupt : Interrupt_ID) do + Lock_Interrupt (Self_ID, Interrupt); + + if Blocked (Interrupt) then + Unlock_Interrupt (Self_ID, Interrupt); + return; + end if; + + Blocked (Interrupt) := True; + Last_Unblocker (Interrupt) := Null_Task; + + -- Mask this task for the given Interrupt so that all tasks + -- are masked for the Interrupt. + + IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt)); + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + -- This is the case where the Server_Task is waiting on + -- "sigwait." Wake it up by sending an Abort_Task_Interrupt + -- so that the Server_Task waits on Cond. + + POP.Abort_Task (Server_ID (Interrupt)); + + -- Make sure corresponding Server_Task is out of its own + -- sigwait state. + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + pragma Assert + (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt)); + end if; + + Unlock_Interrupt (Self_ID, Interrupt); + end Block_Interrupt; + + or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + Lock_Interrupt (Self_ID, Interrupt); + + if not Blocked (Interrupt) then + Unlock_Interrupt (Self_ID, Interrupt); + return; + end if; + + Blocked (Interrupt) := False; + Last_Unblocker (Interrupt) := + To_System (Unblock_Interrupt'Caller); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No handler is attached. Unmask the Interrupt so that + -- the default action can be carried out. + IMOP.Thread_Unblock_Interrupt + (IMNG.Interrupt_ID (Interrupt)); + + else + -- The Server_Task must be waiting on the Cond variable + -- since it was being blocked and an Interrupt Hander or + -- an Entry was there. Wake it up and let it change + -- it place of waiting according to its new state. + POP.Wakeup (Server_ID (Interrupt), + Interrupt_Server_Blocked_Interrupt_Sleep); + end if; + + Unlock_Interrupt (Self_ID, Interrupt); + end Unblock_Interrupt; + + or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + Lock_Interrupt (Self_ID, Interrupt); + + if Ignored (Interrupt) then + Unlock_Interrupt (Self_ID, Interrupt); + return; + end if; + + Ignored (Interrupt) := True; + + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. + + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); + + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + + IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt)); + Unlock_Interrupt (Self_ID, Interrupt); + end Ignore_Interrupt; + + or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + Lock_Interrupt (Self_ID, Interrupt); + Ignored (Interrupt) := False; + + -- If there is a handler associated with the Interrupt, + -- detach it first. In this way we make sure that the + -- Server_Task is not on sigwait. This is legal since + -- Unignore_Interrupt is to install the default action. + + if User_Handler (Interrupt).H /= null then + Unprotected_Detach_Handler + (Interrupt => Interrupt, Static => True); + + elsif User_Entry (Interrupt).T /= Null_Task then + User_Entry (Interrupt) := Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Interrupt); + end if; + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + Unlock_Interrupt (Self_ID, Interrupt); + end Unignore_Interrupt; + + end select; + + exception + + -- If there is a program error we just want to propagate it to + -- the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert + (Shutdown ("Interrupt_Manager---exception not expected")); + null; + end; + + end loop; + + pragma Assert (Shutdown ("Interrupt_Manager---should not get here")); + + end Interrupt_Manager; + + ----------------- + -- Server_Task -- + ----------------- + + task body Server_Task is + Intwait_Mask : aliased IMNG.Interrupt_Mask; + Ret_Interrupt : Interrupt_ID; + Self_ID : Task_ID := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_ID; + Tmp_Entry_Index : Task_Entry_Index; + + begin + -- By making this task independent of master, when the process + -- goes away, the Server_Task will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Install default action in system level. + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked + -- in all tasks. We mask the Interrupt in this particular task + -- so that "sigwait" is possible to catch an explicitely sent + -- Abort_Task_Interrupt from the Interrupt_Manager. + + -- There are two Interrupt interrupts that this task catch through + -- "sigwait." One is the Interrupt this task is designated to catch + -- in order to execure user handler or entry. The other one is the + -- Abort_Task_Interrupt. This interrupt is being sent from the + -- Interrupt_Manager to inform status changes (e.g: become Blocked, + -- Handler or Entry is to be detached). + + -- Prepare a mask to used for sigwait. + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); + + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt); + + IMOP.Thread_Block_Interrupt + (IMNG.Abort_Task_Interrupt); + + PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); + + loop + System.Tasking.Initialization.Defer_Abort (Self_ID); + POP.Write_Lock (Self_ID); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No Interrupt binding. If there is an interrupt, + -- Interrupt_Manager will take default action. + + Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); + Self_ID.Common.State := Runnable; + + elsif Blocked (Interrupt) then + + -- Interrupt is blocked. Stay here, so we won't catch + -- the Interrupt. + + Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep); + Self_ID.Common.State := Runnable; + + else + -- A Handler or an Entry is installed. At this point all tasks + -- mask for the Interrupt is masked. Catch the Interrupt using + -- sigwait. + + -- This task may wake up from sigwait by receiving an interrupt + -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding + -- a Procedure Handler or an Entry. Or it could be a wake up + -- from status change (Unblocked -> Blocked). If that is not + -- the case, we should exceute the attached Procedure or Entry. + + POP.Unlock (Self_ID); + + Ret_Interrupt := + Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access)); + + if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then + + -- Inform the Interrupt_Manager of wakeup from above sigwait. + + POP.Abort_Task (Interrupt_Manager_ID); + POP.Write_Lock (Self_ID); + + else + pragma Assert (Ret_Interrupt = Interrupt); + + POP.Write_Lock (Self_ID); + + -- Even though we have received an Interrupt the status may + -- have changed already before we got the Self_ID lock above. + -- Therefore we make sure a Handler or an Entry is still + -- there and make appropriate call. + -- If there is no calls to make we need to regenerate the + -- Interrupt in order not to lose it. + + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; + + -- RTS calls should not be made with self being locked. + + POP.Unlock (Self_ID); + + Tmp_Handler.all; + POP.Write_Lock (Self_ID); + + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + + -- RTS calls should not be made with self being locked. + + POP.Unlock (Self_ID); + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + POP.Write_Lock (Self_ID); + else + -- This is a situation that this task wake up + -- receiving an Interrupt and before it get the lock + -- the Interrupt is blocked. We do not + -- want to lose the interrupt in this case so that + -- regenerate the Interrupt to process level; + + IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); + end if; + end if; + + end if; + + POP.Unlock (Self_ID); + System.Tasking.Initialization.Undefer_Abort (Self_ID); + + -- Undefer abort here to allow a window for this task + -- to be aborted at the time of system shutdown. + end loop; + + pragma Assert (Shutdown ("Server_Task---should not get here")); + end Server_Task; + +-- Elaboration code for package System.Interrupts + +begin + + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); + + -- Initialize the lock L. + + Initialization.Defer_Abort (Self); + POP.Initialize_Lock (L'Access, POP.PO_Level); + Initialization.Undefer_Abort (Self); + + -- During the elaboration of this package body we want RTS to + -- inherit the interrupt mask from the Environment Task. + + -- The Environment Task should have gotten its mask from + -- the enclosing process during the RTS start up. (See + -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment + -- task to the Interrupt_Manager. + + -- Note : At this point we know that all tasks (including + -- RTS internal servers) are masked for non-reserved signals + -- (see s-taprop.adb). Only the Interrupt_Manager will have + -- masks set up differently inheriting the original Environment + -- Task's mask. + + Interrupt_Manager.Initialize (IMOP.Environment_Mask); +end System.Interrupts; diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads new file mode 100644 index 00000000000..e6cc8836395 --- /dev/null +++ b/gcc/ada/s-interr.ads @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- Copyright (C) 1992-2001 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This package encapsulates the implementation of interrupt or signal +-- handlers. It is logically an extension of the body of Ada.Interrupts. +-- It is made a child of System to allow visibility of various +-- runtime system internal data and operations. + +-- See System.Interrupt_Management for core interrupt/signal interfaces. + +-- These two packages are separated in order to allow +-- System.Interrupt_Management to be used without requiring the whole +-- tasking implementation to be linked and elaborated. + +with System.Tasking; +-- used for Task_ID + +with System.Tasking.Protected_Objects.Entries; +-- used for Protection_Entries + +with System.OS_Interface; +-- used for Max_Interrupt + +package System.Interrupts is + + pragma Elaborate_Body; + -- Comment needed on why this is here ??? + + ------------------------- + -- Constants and types -- + ------------------------- + + Default_Interrupt_Priority : constant System.Interrupt_Priority := + System.Interrupt_Priority'Last; + -- Default value used when a pragma Interrupt_Handler or Attach_Handler is + -- specified without an Interrupt_Priority pragma, see D.3(10). + + type Ada_Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; + -- Avoid inheritance by Ada.Interrupts.Interrupt_ID of unwanted operations + + type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt; + + type Parameterless_Handler is access protected procedure; + + ---------------------- + -- General services -- + ---------------------- + + -- Attempt to attach a Handler to an Interrupt to which an Entry is + -- already bound will raise a Program_Error. + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean; + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean; + + function Current_Handler + (Interrupt : Interrupt_ID) + return Parameterless_Handler; + + -- Calling the following procedures with New_Handler = null + -- and Static = true means that we want to modify the current handler + -- regardless of the previous handler's binding status. + -- (i.e. we do not care whether it is a dynamic or static handler) + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False); + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False); + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False); + + function Reference + (Interrupt : Interrupt_ID) + return System.Address; + + --------------------------------- + -- Interrupt entries services -- + --------------------------------- + + -- Routines needed for Interrupt Entries + -- Attempt to bind an Entry to an Interrupt to which a Handler is + -- already attached will raise a Program_Error. + + procedure Bind_Interrupt_To_Entry + (T : System.Tasking.Task_ID; + E : System.Tasking.Task_Entry_Index; + Int_Ref : System.Address); + + procedure Detach_Interrupt_Entries (T : System.Tasking.Task_ID); + -- This procedure detaches all the Interrupt Entries bound to a task. + + ------------------------------- + -- POSIX.5 signals services -- + ------------------------------- + + -- Routines needed for POSIX dot5 POSIX_Signals + + procedure Block_Interrupt (Interrupt : Interrupt_ID); + -- Block the Interrupt on the process level + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID); + + function Unblocked_By + (Interrupt : Interrupt_ID) + return System.Tasking.Task_ID; + -- It returns the ID of the last Task which Unblocked this Interrupt. + -- It returns Null_Task if no tasks have ever requested the + -- Unblocking operation or the Interrupt is currently Blocked. + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean; + -- Comment needed ??? + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID); + -- Set the sigacion for the interrupt to SIG_IGN. + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID); + -- Comment needed ??? + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean; + -- Comment needed ??? + + -- Note : Direct calls to sigaction, sigprocmask, thr_sigsetmask or any + -- other low-level interface that changes the signal action or signal mask + -- needs a careful thought. + + -- One may acheive the effect of system calls first making RTS blocked + -- (by calling Block_Interrupt) for the signal under consideration. + -- This will make all the tasks in RTS blocked for the Interrupt. + + ---------------------- + -- Protection types -- + ---------------------- + + -- Routines and types needed to implement Interrupt_Handler and + -- Attach_Handler. + + -- There are two kinds of protected objects that deal with interrupts: + + -- (1) Only Interrupt_Handler pragmas are used. We need to be able to + -- tell if an Interrupt_Handler applies to a given procedure, so + -- Register_Interrupt_Handler has to be called for all the potential + -- handlers, it should be done by calling Register_Interrupt_Handler + -- with the handler code address. On finalization, which can happen only + -- has part of library level finalization since PO with + -- Interrupt_Handler pragmas can only be declared at library level, + -- nothing special needs to be done since the default handlers have been + -- restored as part of task completion which is done just before global + -- finalization. Dynamic_Interrupt_Protection should be used in this + -- case. + + -- (2) Attach_Handler pragmas are used, and possibly Interrupt_Handler + -- pragma. We need to attach the handlers to the given interrupts when + -- the objet is elaborated. This should be done by constructing an array + -- of pairs (interrupt, handler) from the pragmas and calling + -- Install_Handlers with it (types to be used are New_Handler_Item and + -- New_Handler_Array). On finalization, we need to restore the handlers + -- that were installed before the elaboration of the PO, so we need to + -- store these previous handlers. This is also done by Install_Handlers, + -- the room for these informations is provided by adding a discriminant + -- which is the number of Attach_Handler pragmas and an array of this + -- size in the protection type, Static_Interrupt_Protection. + + procedure Register_Interrupt_Handler + (Handler_Addr : System.Address); + -- This routine should be called by the compiler to allow the + -- handler be used as an Interrupt Handler. That means call this + -- procedure for each pragma Interrup_Handler providing the + -- address of the handler (not including the pointer to the + -- actual PO, this way this routine is called only once for + -- each type definition of PO). + + type Static_Handler_Index is range 0 .. Integer'Last; + subtype Positive_Static_Handler_Index is + Static_Handler_Index range 1 .. Static_Handler_Index'Last; + -- Comment needed ??? + + type Previous_Handler_Item is record + Interrupt : Interrupt_ID; + Handler : Parameterless_Handler; + Static : Boolean; + end record; + -- Contains all the information needed to restore a previous handler. + + type Previous_Handler_Array is array + (Positive_Static_Handler_Index range <>) of Previous_Handler_Item; + + type New_Handler_Item is record + Interrupt : Interrupt_ID; + Handler : Parameterless_Handler; + end record; + -- Contains all the information from an Attach_Handler pragma. + + type New_Handler_Array is + array (Positive_Static_Handler_Index range <>) of New_Handler_Item; + -- Comment needed ??? + + -- Case (1) + + type Dynamic_Interrupt_Protection is new + Tasking.Protected_Objects.Entries.Protection_Entries with null record; + + -- ??? Finalize is not overloaded since we currently have no + -- way to detach the handlers during library level finalization. + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean; + -- Returns True. + + -- Case (2) + + type Static_Interrupt_Protection + (Num_Entries : Tasking.Protected_Objects.Protected_Entry_Index; + Num_Attach_Handler : Static_Handler_Index) + is new + Tasking.Protected_Objects.Entries.Protection_Entries (Num_Entries) with + record + Previous_Handlers : Previous_Handler_Array (1 .. Num_Attach_Handler); + end record; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean; + -- Returns True. + + procedure Finalize (Object : in out Static_Interrupt_Protection); + -- Restore previous handlers as required by C.3.1(12) then call + -- Finalize (Protection). + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : in New_Handler_Array); + -- Store the old handlers in Object.Previous_Handlers and install + -- the new static handlers. + +end System.Interrupts; diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads new file mode 100644 index 00000000000..0f89bd7f508 --- /dev/null +++ b/gcc/ada/s-intman.ads @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 1991-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 encapsulates and centralizes information about +-- all uses of interrupts (or signals), including the +-- target-dependent mapping of interrupts (or signals) to exceptions. + +-- PLEASE DO NOT add any with-clauses to this package. +-- This is designed to work for both tasking and non-tasking systems, +-- without pulling in any of the tasking support. + +-- PLEASE DO NOT remove the Elaborate_Body pragma from this package. +-- Elaboration of this package should happen early, as most other +-- initializations depend on it. +-- Forcing immediate elaboration of the body also helps to enforce +-- the design assumption that this is a second-level +-- package, just one level above System.OS_Interface, with no +-- cross-dependences. + +-- PLEASE DO NOT put any subprogram declarations with arguments of +-- type Interrupt_ID into the visible part of this package. +-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, +-- and adding more operations to that type would be illegal according +-- to the Ada Reference Manual. (This is the reason why the signals sets +-- below are implemented as visible arrays rather than functions.) + +with System.OS_Interface; +-- used for Signal +-- sigset_t + +package System.Interrupt_Management is + + pragma Elaborate_Body; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new System.OS_Interface.Signal; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + -- The following objects serve as constants, but are initialized + -- in the body to aid portability. This permits us + -- to use more portable names for interrupts, + -- where distinct names may map to the same interrupt ID value. + -- For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. + -- If we have the convention that ID zero is not used for any "real" + -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally + -- supported signals, we can write + -- Reserved (SIGRARE) := true; + -- and the initialization code will be portable. + + Abort_Task_Interrupt : Interrupt_ID; + -- The interrupt that is used to implement task abortion, + -- if an interrupt is used for that purpose. + -- This is one of the reserved interrupts. + + Keep_Unmasked : Interrupt_Set := (others => False); + -- Keep_Unmasked (I) is true iff the interrupt I is + -- one that must be kept unmasked at all times, + -- except (perhaps) for short critical sections. + -- This includes interrupts that are mapped to exceptions + -- (see System.Interrupt_Exceptions.Is_Exception), but may also + -- include interrupts (e.g. timer) that need to be kept unmasked + -- for other reasons. + -- Where interrupts are implemented as OS signals, and signal masking + -- is per-task, the interrupt should be unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that + -- cannot be permitted to be attached to a user handler. + -- The possible reasons are many. For example, + -- it may be mapped to an exception, used to implement task abortion, + -- or used to implement time delays. + + Keep_Masked : Interrupt_Set := (others => False); + -- Keep_Masked (I) is true iff the interrupt I must always be masked. + -- Where interrupts are implemented as OS signals, and signal masking + -- is per-task, the interrupt should be masked in ALL TASKS. + -- There might not be any interrupts in this class, depending on + -- the environment. For example, if interrupts are OS signals + -- and signal masking is per-task, use of the sigwait operation + -- requires the signal be masked in all tasks. + + procedure Initialize_Interrupts; + -- On systems where there is no signal inheritance between tasks (e.g + -- VxWorks, LinuxThreads), this procedure is used to initialize interrupts + -- handling in each task. Otherwise this function should only be called by + -- initialize in this package body. + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- in some implementation Interrupt_Mask can be represented + -- as a linked list. +end System.Interrupt_Management; diff --git a/gcc/ada/s-io.adb b/gcc/ada/s-io.adb new file mode 100644 index 00000000000..b768d9ac2ac --- /dev/null +++ b/gcc/ada/s-io.adb @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.IO is + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (Spacing : Positive := 1) is + begin + for J in 1 .. Spacing loop + Put (ASCII.LF); + end loop; + end New_Line; + + --------- + -- Put -- + --------- + + procedure Put (X : Integer) is + + procedure Put_Int (X : Integer); + pragma Import (C, Put_Int, "put_int"); + + begin + Put_Int (X); + end Put; + + procedure Put (C : Character) is + + procedure Put_Char (C : Character); + pragma Import (C, Put_Char, "put_char"); + + begin + Put_Char (C); + end Put; + + procedure Put (S : String) is + begin + for J in S'Range loop + Put (S (J)); + end loop; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + Put (S); + New_Line; + end Put_Line; + +end System.IO; diff --git a/gcc/ada/s-io.ads b/gcc/ada/s-io.ads new file mode 100644 index 00000000000..a722736eed8 --- /dev/null +++ b/gcc/ada/s-io.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M _ I O -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- A simple text I/O package, used for diagnostic output in the runtime, +-- This package is also preelaborated, unlike Text_Io, and can thus be +-- with'ed by preelaborated library units. It includes only Put routines +-- for character, integer, string and a new line function + +package System.IO is +pragma Preelaborate (IO); + + procedure Put (X : Integer); + + procedure Put (C : Character); + + procedure Put (S : String); + procedure Put_Line (S : String); + + procedure New_Line (Spacing : Positive := 1); + +end System.IO; diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads new file mode 100644 index 00000000000..cecdb082dc8 --- /dev/null +++ b/gcc/ada/s-maccod.ads @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . M A C H I N E _ C O D E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- 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 machine code support, both for instrinsic machine +-- operations, and also for machine code statements. See GNAT documentation +-- for full details. + +package System.Machine_Code is +pragma Pure (Machine_Code); + + type Asm_Input_Operand is private; + type Asm_Output_Operand is private; + -- These types are never used directly, they are declared only so that + -- the calls to Asm are type correct according to Ada semantic rules. + + No_Input_Operands : constant Asm_Input_Operand; + No_Output_Operands : constant Asm_Output_Operand; + + type Asm_Input_Operand_List is + array (Integer range <>) of Asm_Input_Operand; + + type Asm_Output_Operand_List is + array (Integer range <>) of Asm_Output_Operand; + + type Asm_Insn is private; + -- This type is not used directly. It is declared only so that the + -- aggregates used in code statements are type correct by Ada rules. + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False); + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False); + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False); + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False); + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False) + return Asm_Insn; + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False) + return Asm_Insn; + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False) + return Asm_Insn; + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False) + return Asm_Insn; + + pragma Import (Intrinsic, Asm); + +private + + type Asm_Input_Operand is new Integer; + type Asm_Output_Operand is new Integer; + type Asm_Insn is new Integer; + -- All three of these types are dummy types, to meet the requirements of + -- type consistenty. No values of these types are ever referenced. + + No_Input_Operands : constant Asm_Input_Operand := 0; + No_Output_Operands : constant Asm_Output_Operand := 0; + +end System.Machine_Code; diff --git a/gcc/ada/s-mantis.adb b/gcc/ada/s-mantis.adb new file mode 100644 index 00000000000..ff9cb8b9e7d --- /dev/null +++ b/gcc/ada/s-mantis.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . M A N T I S S A -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 System.Mantissa is + + -------------------- + -- Mantissa_Value -- + -------------------- + + function Mantissa_Value (First, Last : Integer) return Natural is + Result : Natural := 0; + + Val : Integer := Integer'Max (abs First - 1, abs Last); + -- Note: First-1 allows for twos complement largest neg number + + begin + while Val /= 0 loop + Val := Val / 2; + Result := Result + 1; + end loop; + + return Result; + end Mantissa_Value; + +end System.Mantissa; diff --git a/gcc/ada/s-mantis.ads b/gcc/ada/s-mantis.ads new file mode 100644 index 00000000000..ae5b5a679c8 --- /dev/null +++ b/gcc/ada/s-mantis.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . M A N T I S S A -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- Copyright (C) 1996 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 routine used for typ'Mantissa where typ is a +-- fixed-point type with non-static bounds. + +package System.Mantissa is +pragma Pure (Mantissa); + + function Mantissa_Value (First, Last : Integer) return Natural; + -- Compute Mantissa value from the given arguments, which are the First + -- and Last value of the fixed-point type, in Integer'Integer_Value form. + +end System.Mantissa; diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb new file mode 100644 index 00000000000..16e7de2ff70 --- /dev/null +++ b/gcc/ada/s-mastop.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Dummy version) -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This dummy version of System.Machine_State_Operations is used +-- on targets for which zero cost exception handling is not implemented. + +package body System.Machine_State_Operations is + + use System.Exceptions; + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + begin + return Machine_State (Null_Address); + end Allocate_Machine_State; + + ------------------- + -- Enter_Handler -- + ------------------- + + procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is + begin + null; + end Enter_Handler; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + return Loc; + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + begin + return Null_Address; + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset is + begin + return 0; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame + (M : Machine_State; + Info : Subprogram_Info_Type) is + begin + null; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + begin + null; + end Set_Machine_State; + + ------------------------------ + -- Set_Signal_Machine_State -- + ------------------------------ + + procedure Set_Signal_Machine_State + (M : Machine_State; + Context : System.Address) is + begin + null; + end Set_Signal_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop.ads b/gcc/ada/s-mastop.ads new file mode 100644 index 00000000000..ef0282bf524 --- /dev/null +++ b/gcc/ada/s-mastop.ads @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +with System.Storage_Elements; +with System.Exceptions; + +package System.Machine_State_Operations is + + 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. + + type Machine_State is new System.Address; + -- The table based exception handling approach (see a-except.adb) isolates + -- the target dependent aspects using an abstract data type interface + -- to the type Machine_State, which is represented as a System.Address + -- value (presumably implemented as a pointer to an appropriate record + -- structure). + + function Machine_State_Length return System.Storage_Elements.Storage_Offset; + -- Function to determine the length of the Storage_Array needed to hold + -- a machine state. The machine state will always be maximally aligned. + -- The value returned is a constant that will be used to allocate space + -- for a machine state value. + + function Allocate_Machine_State return Machine_State; + -- Allocate the required space for a Machine_State + + procedure Free_Machine_State (M : in out Machine_State); + -- Free the dynamic memory taken by Machine_State + + -- The initial value of type Machine_State is created by the low level + -- routine that actually raises an exception using the special builtin + -- _builtin_machine_state. This value will typically encode the value + -- of the program counter, and relevant registers. The following + -- operations are defined on Machine_State values: + + function Get_Code_Loc (M : Machine_State) return Code_Loc; + -- This function extracts the program counter value from a machine + -- state, which the caller uses for searching the exception tables, + -- and also for recording entries in the traceback table. The call + -- returns a value of Null_Loc if the machine state represents the + -- outer level, or some other frame for which no information can be + -- provided. + + procedure Pop_Frame + (M : Machine_State; + Info : System.Exceptions.Subprogram_Info_Type); + -- This procedure pops the machine state M so that it represents the + -- call point, as though the current subprogram had returned. It + -- changes only the value referenced by M, and does not affect + -- the current stack environment. + -- + -- The Info parameter represents information generated by the backend + -- (see description of Subprogram_Info node in sinfo.ads). This + -- information is stored as static data during compilation. The + -- caller then passes this information to Pop_Frame, which will + -- use it to determine what must be changed in the machine state + -- (e.g. which save-over-call registers must be restored, and from + -- where on the stack frame they must be restored). + -- + -- A value of No_Info for Info means either that the backend provided + -- no information for current frame, or that the current frame is an + -- other language frame for which no information exists, or that this + -- is an outer level subprogram. In any case, Pop_Frame sets the code + -- location to Null_Address when it pops past such a frame, and this + -- is taken as an indication that the exception is unhandled. + + -- Note: at the current time, Info, if present is always a copy of + -- the entry point of the procedure, as found by searching the + -- subprogram table. For the case where a procedure is indeed in + -- the table (either it is an Ada procedure, or a foreign procedure + -- which is registered using pragma Propagate_Exceptions), then the + -- entry point information will indeed be correct. It may well be + -- possible for Pop_Frame to avoid using the Info parameter (for + -- example if it consults auxiliary Dwarf tables to do its job). + -- This is desirable if it can be done, because it means that it + -- will work fine to propagate exceptions through unregistered + -- foreign procedures. What will happen is that the search in the + -- Ada subprogram table will find a junk entry. Even if this junk + -- entry has an exception table, none of them will apply to the + -- current location, so they will be ignored, and then Pop_Frame + -- will be called to pop the frame. The Info parameter for this + -- call will be junk, but if it is not used that does not matter. + -- Note that the address recorded in the traceback table is of + -- the exception location, so the traceback will be correct even + -- in this case. + + procedure Enter_Handler + (M : Machine_State; + Handler : System.Exceptions.Handler_Loc); + -- When Propagate_Handler locates an applicable exception handler, it + -- calls Enter_Handler, passing it two parameters. The first is the + -- machine state that corresponds to what is required for entry to + -- the handler, as computed by repeated Pop_Frame calls to reach the + -- handler to be entered. The second is the code location for the + -- handler itself which is the address of the label at the start of + -- the handler code. + -- + -- Note: The machine state M is likely stored on the part of the + -- stack that will be popped by the call, so care must be taken + -- not to pop the stack until the Machine_State is entirely read. + -- The value passed as Handler was obtained from elaboration of + -- an N_Handler_Loc node by the backend. + + function Fetch_Code (Loc : Code_Loc) return Code_Loc; + -- Some architectures (notably VMS) use a descriptor to describe + -- a subprogram address. This function computes the actual starting + -- address of the code from Loc. + -- Do not add pragma Inline, see 9116-002. + -- ??? This function will go away when 'Code_Address is fixed on VMS. + + procedure Set_Machine_State (M : Machine_State); + -- This routine sets M from the current machine state. It is called + -- when an exception is initially signalled to initialize the state. + + procedure Set_Signal_Machine_State + (M : Machine_State; + Context : System.Address); + -- This routine sets M from the machine state that corresponds to the + -- point in the code where a signal was raised. The parameter Context + -- is a pointer to a structure created by the operating system when a + -- signal is raised, and made available to the signal handler. The + -- format of this context block, and the manner in which it is made + -- available to the handler, are implementation dependent. + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb new file mode 100644 index 00000000000..4f11aeca738 --- /dev/null +++ b/gcc/ada/s-memory.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 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 is the default implementation of this package. + +-- This implementation assumes that the underlying malloc/free/realloc +-- implementation is thread safe, and thus, no additional lock is required. +-- Note that we still need to defer abortion because on most systems, +-- an asynchronous signal (as used for implementing asynchronous abortion +-- of task) cannot safely be handled while malloc is executing. + +-- If you are not using Ada constructs containing the "abort" keyword, +-- then you can remove the calls to Abort_Defer.all and Abort_Undefer.all +-- from this unit. + +with Ada.Exceptions; +with System.Soft_Links; + +package body System.Memory is + + use Ada.Exceptions; + use System.Soft_Links; + + function c_malloc (Size : size_t) return System.Address; + pragma Import (C, c_malloc, "malloc"); + + procedure c_free (Ptr : System.Address); + pragma Import (C, c_free, "free"); + + function c_realloc + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, c_realloc, "realloc"); + + ----------- + -- Alloc -- + ----------- + + function Alloc (Size : size_t) return System.Address is + Result : System.Address; + Actual_Size : size_t := Size; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + -- Change size from zero to non-zero. We still want a proper pointer + -- for the zero case because pointers to zero length objects have to + -- be distinct, but we can't just go ahead and allocate zero bytes, + -- since some malloc's return zero for a zero argument. + + if Size = 0 then + Actual_Size := 1; + end if; + + Abort_Defer.all; + Result := c_malloc (Actual_Size); + Abort_Undefer.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Alloc; + + ---------- + -- Free -- + ---------- + + procedure Free (Ptr : System.Address) is + begin + Abort_Defer.all; + c_free (Ptr); + Abort_Undefer.all; + end Free; + + ------------- + -- Realloc -- + ------------- + + function Realloc + (Ptr : System.Address; + Size : size_t) + return System.Address + is + Result : System.Address; + Actual_Size : size_t := Size; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + Abort_Defer.all; + Result := c_realloc (Ptr, Actual_Size); + Abort_Undefer.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Realloc; + +end System.Memory; diff --git a/gcc/ada/s-memory.ads b/gcc/ada/s-memory.ads new file mode 100644 index 00000000000..6dafe93b877 --- /dev/null +++ b/gcc/ada/s-memory.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 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 provides the low level memory allocation/deallocation +-- mechanisms used by GNAT. + +-- To provide an alternate implementation, simply recompile the modified +-- body of this package with gnatmake -u -a -g s-memory.adb and make sure +-- that the ali and object files for this unit are found in the object +-- search path. + +package System.Memory is + pragma Elaborate_Body; + + type size_t is mod 2 ** Standard'Address_Size; + + function Alloc (Size : size_t) return System.Address; + -- malloc for use by GNAT, with error checking and task lockout, + -- as well as allocation tracking. + + procedure Free (Ptr : System.Address); + -- free for use by GNAT, with task lockout and allocation tracking. + + function Realloc + (Ptr : System.Address; + Size : size_t) + return System.Address; + -- realloc for use by GNAT, with error checking and task lockout. + +private + + pragma Export (C, Alloc, "__gnat_malloc"); + pragma Export (C, Free, "__gnat_free"); + pragma Export (C, Realloc, "__gnat_realloc"); + +end System.Memory; diff --git a/gcc/ada/s-osprim.ads b/gcc/ada/s-osprim.ads new file mode 100644 index 00000000000..2ee6ae077b3 --- /dev/null +++ b/gcc/ada/s-osprim.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- Copyright (C) 1998-2001 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 provides low level primitives used to implement clock and +-- delays in non tasking applications. + +-- The choice of the real clock/delay implementation (depending on whether +-- tasking is involved or not) is done via soft links (see s-tasoli.ads) + +-- NEVER add any dependency to tasking packages here + +package System.OS_Primitives is + + Max_Sensible_Delay : constant Duration := 183 * 24 * 60 * 60.0; + -- Max of half a year delay, needed to prevent exceptions for large + -- delay values. It seems unlikely that any test will notice this + -- restriction, except in the case of applications setting the clock at + -- at run time (see s-tastim.adb). Also note that a larger value might + -- cause problems (e.g overflow, or more likely OS limitation in the + -- primitives used). + + function Clock return Duration; + pragma Inline (Clock); + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Jan 1, 1970 on unixes. + -- This implementation is affected by system's clock changes. + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Jan 1, 1970. + -- This clock implementation is immune to the system's clock changes. + + Relative : constant := 0; + Absolute_Calendar : constant := 1; + Absolute_RT : constant := 2; + -- Values for Mode call below. Note that the compiler (exp_ch9.adb) + -- relies on these values. So any change here must be reflected in + -- corresponding changes in the compiler. + + procedure Timed_Delay (Time : Duration; Mode : Integer); + -- Implements the semantics of the delay statement when no tasking is + -- used in the application. + -- + -- Mode is one of the three values above + -- + -- Time is a relative or absolute duration value, depending on Mode. + -- + -- Note that currently Ada.Real_Time always uses the tasking run time, so + -- this procedure should never be called with Mode set to Absolute_RT. + -- This may change in future or bare board implementations. + +end System.OS_Primitives; diff --git a/gcc/ada/s-pack03.adb b/gcc/ada/s-pack03.adb new file mode 100644 index 00000000000..e93835b5ded --- /dev/null +++ b/gcc/ada/s-pack03.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_03 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_03; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_03 -- + ------------ + + function Get_03 (Arr : System.Address; N : Natural) return Bits_03 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_03; + + ------------ + -- Set_03 -- + ------------ + + procedure Set_03 (Arr : System.Address; N : Natural; E : Bits_03) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_03; + +end System.Pack_03; diff --git a/gcc/ada/s-pack03.ads b/gcc/ada/s-pack03.ads new file mode 100644 index 00000000000..a9c3c27e1ef --- /dev/null +++ b/gcc/ada/s-pack03.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 3 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Handing of packed arrays with Component_Size = 3 + +package System.Pack_03 is +pragma Preelaborate (Pack_03); + + Bits : constant := 3; + + type Bits_03 is mod 2 ** Bits; + for Bits_03'Size use Bits; + + function Get_03 (Arr : System.Address; N : Natural) return Bits_03; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_03 (Arr : System.Address; N : Natural; E : Bits_03); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_03; diff --git a/gcc/ada/s-pack05.adb b/gcc/ada/s-pack05.adb new file mode 100644 index 00000000000..8ebb5ba829e --- /dev/null +++ b/gcc/ada/s-pack05.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_05 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_05; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_05 -- + ------------ + + function Get_05 (Arr : System.Address; N : Natural) return Bits_05 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_05; + + ------------ + -- Set_05 -- + ------------ + + procedure Set_05 (Arr : System.Address; N : Natural; E : Bits_05) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_05; + +end System.Pack_05; diff --git a/gcc/ada/s-pack05.ads b/gcc/ada/s-pack05.ads new file mode 100644 index 00000000000..f025a26ae04 --- /dev/null +++ b/gcc/ada/s-pack05.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 5 -- +-- -- +-- 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-0507, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 5 + +package System.Pack_05 is +pragma Preelaborate (Pack_05); + + Bits : constant := 5; + + type Bits_05 is mod 2 ** Bits; + for Bits_05'Size use Bits; + + function Get_05 (Arr : System.Address; N : Natural) return Bits_05; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_05 (Arr : System.Address; N : Natural; E : Bits_05); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_05; diff --git a/gcc/ada/s-pack06.adb b/gcc/ada/s-pack06.adb new file mode 100644 index 00000000000..8d48bb8f423 --- /dev/null +++ b/gcc/ada/s-pack06.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 6 -- +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_06 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_06; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_06 or SetU_06 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_06 -- + ------------ + + function Get_06 (Arr : System.Address; N : Natural) return Bits_06 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_06; + + ------------- + -- GetU_06 -- + ------------- + + function GetU_06 (Arr : System.Address; N : Natural) return Bits_06 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_06; + + ------------ + -- Set_06 -- + ------------ + + procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_06; + + ------------- + -- SetU_06 -- + ------------- + + procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_06; + +end System.Pack_06; diff --git a/gcc/ada/s-pack06.ads b/gcc/ada/s-pack06.ads new file mode 100644 index 00000000000..d35607fa184 --- /dev/null +++ b/gcc/ada/s-pack06.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 6 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 6 + +package System.Pack_06 is +pragma Preelaborate (Pack_06); + + Bits : constant := 6; + + type Bits_06 is mod 2 ** Bits; + for Bits_06'Size use Bits; + + function Get_06 (Arr : System.Address; N : Natural) return Bits_06; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_06 (Arr : System.Address; N : Natural) return Bits_06; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_06; diff --git a/gcc/ada/s-pack07.adb b/gcc/ada/s-pack07.adb new file mode 100644 index 00000000000..510ddecd043 --- /dev/null +++ b/gcc/ada/s-pack07.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 7 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_07 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_07; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_07 -- + ------------ + + function Get_07 (Arr : System.Address; N : Natural) return Bits_07 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_07; + + ------------ + -- Set_07 -- + ------------ + + procedure Set_07 (Arr : System.Address; N : Natural; E : Bits_07) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_07; + +end System.Pack_07; diff --git a/gcc/ada/s-pack07.ads b/gcc/ada/s-pack07.ads new file mode 100644 index 00000000000..e0ae2b9cf2a --- /dev/null +++ b/gcc/ada/s-pack07.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 7 -- +-- -- +-- 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-0707, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 7 + +package System.Pack_07 is +pragma Preelaborate (Pack_07); + + Bits : constant := 7; + + type Bits_07 is mod 2 ** Bits; + for Bits_07'Size use Bits; + + function Get_07 (Arr : System.Address; N : Natural) return Bits_07; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_07 (Arr : System.Address; N : Natural; E : Bits_07); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_07; diff --git a/gcc/ada/s-pack09.adb b/gcc/ada/s-pack09.adb new file mode 100644 index 00000000000..26931bf2982 --- /dev/null +++ b/gcc/ada/s-pack09.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 9 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_09 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_09; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_09 -- + ------------ + + function Get_09 (Arr : System.Address; N : Natural) return Bits_09 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_09; + + ------------ + -- Set_09 -- + ------------ + + procedure Set_09 (Arr : System.Address; N : Natural; E : Bits_09) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_09; + +end System.Pack_09; diff --git a/gcc/ada/s-pack09.ads b/gcc/ada/s-pack09.ads new file mode 100644 index 00000000000..017dd582636 --- /dev/null +++ b/gcc/ada/s-pack09.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 9 -- +-- -- +-- 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-0907, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 9 + +package System.Pack_09 is +pragma Preelaborate (Pack_09); + + Bits : constant := 9; + + type Bits_09 is mod 2 ** Bits; + for Bits_09'Size use Bits; + + function Get_09 (Arr : System.Address; N : Natural) return Bits_09; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_09 (Arr : System.Address; N : Natural; E : Bits_09); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_09; diff --git a/gcc/ada/s-pack10.adb b/gcc/ada/s-pack10.adb new file mode 100644 index 00000000000..42442e18976 --- /dev/null +++ b/gcc/ada/s-pack10.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_10 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_10; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_10 or SetU_10 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_10 -- + ------------ + + function Get_10 (Arr : System.Address; N : Natural) return Bits_10 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_10; + + ------------- + -- GetU_10 -- + ------------- + + function GetU_10 (Arr : System.Address; N : Natural) return Bits_10 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_10; + + ------------ + -- Set_10 -- + ------------ + + procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_10; + + ------------- + -- SetU_10 -- + ------------- + + procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_10; + +end System.Pack_10; diff --git a/gcc/ada/s-pack10.ads b/gcc/ada/s-pack10.ads new file mode 100644 index 00000000000..97c98b46cae --- /dev/null +++ b/gcc/ada/s-pack10.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 10 + +package System.Pack_10 is +pragma Preelaborate (Pack_10); + + Bits : constant := 10; + + type Bits_10 is mod 2 ** Bits; + for Bits_10'Size use Bits; + + function Get_10 (Arr : System.Address; N : Natural) return Bits_10; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_10 (Arr : System.Address; N : Natural) return Bits_10; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_10; diff --git a/gcc/ada/s-pack11.adb b/gcc/ada/s-pack11.adb new file mode 100644 index 00000000000..ca4f51ccfc5 --- /dev/null +++ b/gcc/ada/s-pack11.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_11 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_11; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_11 -- + ------------ + + function Get_11 (Arr : System.Address; N : Natural) return Bits_11 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_11; + + ------------ + -- Set_11 -- + ------------ + + procedure Set_11 (Arr : System.Address; N : Natural; E : Bits_11) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_11; + +end System.Pack_11; diff --git a/gcc/ada/s-pack11.ads b/gcc/ada/s-pack11.ads new file mode 100644 index 00000000000..8eb527b1c24 --- /dev/null +++ b/gcc/ada/s-pack11.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 -- +-- -- +-- 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-1107, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 11 + +package System.Pack_11 is +pragma Preelaborate (Pack_11); + + Bits : constant := 11; + + type Bits_11 is mod 2 ** Bits; + for Bits_11'Size use Bits; + + function Get_11 (Arr : System.Address; N : Natural) return Bits_11; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_11 (Arr : System.Address; N : Natural; E : Bits_11); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_11; diff --git a/gcc/ada/s-pack12.adb b/gcc/ada/s-pack12.adb new file mode 100644 index 00000000000..958c88140ba --- /dev/null +++ b/gcc/ada/s-pack12.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_12 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_12; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_12 or SetU_12 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_12 -- + ------------ + + function Get_12 (Arr : System.Address; N : Natural) return Bits_12 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_12; + + ------------- + -- GetU_12 -- + ------------- + + function GetU_12 (Arr : System.Address; N : Natural) return Bits_12 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_12; + + ------------ + -- Set_12 -- + ------------ + + procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_12; + + ------------- + -- SetU_12 -- + ------------- + + procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_12; + +end System.Pack_12; diff --git a/gcc/ada/s-pack12.ads b/gcc/ada/s-pack12.ads new file mode 100644 index 00000000000..c31b9b6237b --- /dev/null +++ b/gcc/ada/s-pack12.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 12 + +package System.Pack_12 is +pragma Preelaborate (Pack_12); + + Bits : constant := 12; + + type Bits_12 is mod 2 ** Bits; + for Bits_12'Size use Bits; + + function Get_12 (Arr : System.Address; N : Natural) return Bits_12; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_12 (Arr : System.Address; N : Natural) return Bits_12; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_12; diff --git a/gcc/ada/s-pack13.adb b/gcc/ada/s-pack13.adb new file mode 100644 index 00000000000..9da7f1cdf0c --- /dev/null +++ b/gcc/ada/s-pack13.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_13 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_13; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_13 -- + ------------ + + function Get_13 (Arr : System.Address; N : Natural) return Bits_13 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_13; + + ------------ + -- Set_13 -- + ------------ + + procedure Set_13 (Arr : System.Address; N : Natural; E : Bits_13) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_13; + +end System.Pack_13; diff --git a/gcc/ada/s-pack13.ads b/gcc/ada/s-pack13.ads new file mode 100644 index 00000000000..b0b89760a00 --- /dev/null +++ b/gcc/ada/s-pack13.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 3 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 13 + +package System.Pack_13 is +pragma Preelaborate (Pack_13); + + Bits : constant := 13; + + type Bits_13 is mod 2 ** Bits; + for Bits_13'Size use Bits; + + function Get_13 (Arr : System.Address; N : Natural) return Bits_13; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_13 (Arr : System.Address; N : Natural; E : Bits_13); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_13; diff --git a/gcc/ada/s-pack14.adb b/gcc/ada/s-pack14.adb new file mode 100644 index 00000000000..cc4c5cea3ac --- /dev/null +++ b/gcc/ada/s-pack14.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 4 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_14 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_14; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_14 or SetU_14 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_14 -- + ------------ + + function Get_14 (Arr : System.Address; N : Natural) return Bits_14 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_14; + + ------------- + -- GetU_14 -- + ------------- + + function GetU_14 (Arr : System.Address; N : Natural) return Bits_14 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_14; + + ------------ + -- Set_14 -- + ------------ + + procedure Set_14 (Arr : System.Address; N : Natural; E : Bits_14) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_14; + + ------------- + -- SetU_14 -- + ------------- + + procedure SetU_14 (Arr : System.Address; N : Natural; E : Bits_14) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_14; + +end System.Pack_14; diff --git a/gcc/ada/s-pack14.ads b/gcc/ada/s-pack14.ads new file mode 100644 index 00000000000..cceb1ba27dc --- /dev/null +++ b/gcc/ada/s-pack14.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 4 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handing of packed arrays with Component_Size = 14 + +package System.Pack_14 is +pragma Preelaborate (Pack_14); + + Bits : constant := 14; + + type Bits_14 is mod 2 ** Bits; + for Bits_14'Size use Bits; + + function Get_14 (Arr : System.Address; N : Natural) return Bits_14; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_14 (Arr : System.Address; N : Natural; E : Bits_14); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_14 (Arr : System.Address; N : Natural) return Bits_14; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_14 (Arr : System.Address; N : Natural; E : Bits_14); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_14; diff --git a/gcc/ada/s-pack15.adb b/gcc/ada/s-pack15.adb new file mode 100644 index 00000000000..64f8ba584fa --- /dev/null +++ b/gcc/ada/s-pack15.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_15 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_15; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_15 -- + ------------ + + function Get_15 (Arr : System.Address; N : Natural) return Bits_15 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_15; + + ------------ + -- Set_15 -- + ------------ + + procedure Set_15 (Arr : System.Address; N : Natural; E : Bits_15) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_15; + +end System.Pack_15; diff --git a/gcc/ada/s-pack15.ads b/gcc/ada/s-pack15.ads new file mode 100644 index 00000000000..3861797dd53 --- /dev/null +++ b/gcc/ada/s-pack15.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 5 -- +-- -- +-- 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-1507, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 15 + +package System.Pack_15 is +pragma Preelaborate (Pack_15); + + Bits : constant := 15; + + type Bits_15 is mod 2 ** Bits; + for Bits_15'Size use Bits; + + function Get_15 (Arr : System.Address; N : Natural) return Bits_15; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_15 (Arr : System.Address; N : Natural; E : Bits_15); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_15; diff --git a/gcc/ada/s-pack17.adb b/gcc/ada/s-pack17.adb new file mode 100644 index 00000000000..0fa9a1da0b6 --- /dev/null +++ b/gcc/ada/s-pack17.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 7 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_17 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_17; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_17 -- + ------------ + + function Get_17 (Arr : System.Address; N : Natural) return Bits_17 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_17; + + ------------ + -- Set_17 -- + ------------ + + procedure Set_17 (Arr : System.Address; N : Natural; E : Bits_17) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_17; + +end System.Pack_17; diff --git a/gcc/ada/s-pack17.ads b/gcc/ada/s-pack17.ads new file mode 100644 index 00000000000..697d2f39afb --- /dev/null +++ b/gcc/ada/s-pack17.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 7 -- +-- -- +-- 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-1707, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 17 + +package System.Pack_17 is +pragma Preelaborate (Pack_17); + + Bits : constant := 17; + + type Bits_17 is mod 2 ** Bits; + for Bits_17'Size use Bits; + + function Get_17 (Arr : System.Address; N : Natural) return Bits_17; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_17 (Arr : System.Address; N : Natural; E : Bits_17); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_17; diff --git a/gcc/ada/s-pack18.adb b/gcc/ada/s-pack18.adb new file mode 100644 index 00000000000..6741f1b77cc --- /dev/null +++ b/gcc/ada/s-pack18.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 8 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_18 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_18; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_18 or SetU_18 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_18 -- + ------------ + + function Get_18 (Arr : System.Address; N : Natural) return Bits_18 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_18; + + ------------- + -- GetU_18 -- + ------------- + + function GetU_18 (Arr : System.Address; N : Natural) return Bits_18 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_18; + + ------------ + -- Set_18 -- + ------------ + + procedure Set_18 (Arr : System.Address; N : Natural; E : Bits_18) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_18; + + ------------- + -- SetU_18 -- + ------------- + + procedure SetU_18 (Arr : System.Address; N : Natural; E : Bits_18) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_18; + +end System.Pack_18; diff --git a/gcc/ada/s-pack18.ads b/gcc/ada/s-pack18.ads new file mode 100644 index 00000000000..7f3b78f5307 --- /dev/null +++ b/gcc/ada/s-pack18.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 8 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 18 + +package System.Pack_18 is +pragma Preelaborate (Pack_18); + + Bits : constant := 18; + + type Bits_18 is mod 2 ** Bits; + for Bits_18'Size use Bits; + + function Get_18 (Arr : System.Address; N : Natural) return Bits_18; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_18 (Arr : System.Address; N : Natural; E : Bits_18); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_18 (Arr : System.Address; N : Natural) return Bits_18; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_18 (Arr : System.Address; N : Natural; E : Bits_18); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_18; diff --git a/gcc/ada/s-pack19.adb b/gcc/ada/s-pack19.adb new file mode 100644 index 00000000000..2aea9eae4cd --- /dev/null +++ b/gcc/ada/s-pack19.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 9 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_19 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_19; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_19 -- + ------------ + + function Get_19 (Arr : System.Address; N : Natural) return Bits_19 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_19; + + ------------ + -- Set_19 -- + ------------ + + procedure Set_19 (Arr : System.Address; N : Natural; E : Bits_19) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_19; + +end System.Pack_19; diff --git a/gcc/ada/s-pack19.ads b/gcc/ada/s-pack19.ads new file mode 100644 index 00000000000..c5103605247 --- /dev/null +++ b/gcc/ada/s-pack19.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 9 -- +-- -- +-- 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-1907, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 19 + +package System.Pack_19 is +pragma Preelaborate (Pack_19); + + Bits : constant := 19; + + type Bits_19 is mod 2 ** Bits; + for Bits_19'Size use Bits; + + function Get_19 (Arr : System.Address; N : Natural) return Bits_19; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_19 (Arr : System.Address; N : Natural; E : Bits_19); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_19; diff --git a/gcc/ada/s-pack20.adb b/gcc/ada/s-pack20.adb new file mode 100644 index 00000000000..9a09533a927 --- /dev/null +++ b/gcc/ada/s-pack20.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 0 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_20 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_20; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_20 or SetU_20 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_20 -- + ------------ + + function Get_20 (Arr : System.Address; N : Natural) return Bits_20 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_20; + + ------------- + -- GetU_20 -- + ------------- + + function GetU_20 (Arr : System.Address; N : Natural) return Bits_20 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_20; + + ------------ + -- Set_20 -- + ------------ + + procedure Set_20 (Arr : System.Address; N : Natural; E : Bits_20) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_20; + + ------------- + -- SetU_20 -- + ------------- + + procedure SetU_20 (Arr : System.Address; N : Natural; E : Bits_20) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_20; + +end System.Pack_20; diff --git a/gcc/ada/s-pack20.ads b/gcc/ada/s-pack20.ads new file mode 100644 index 00000000000..626f2ccf1aa --- /dev/null +++ b/gcc/ada/s-pack20.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 0 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 20 + +package System.Pack_20 is +pragma Preelaborate (Pack_20); + + Bits : constant := 20; + + type Bits_20 is mod 2 ** Bits; + for Bits_20'Size use Bits; + + function Get_20 (Arr : System.Address; N : Natural) return Bits_20; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_20 (Arr : System.Address; N : Natural; E : Bits_20); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_20 (Arr : System.Address; N : Natural) return Bits_20; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_20 (Arr : System.Address; N : Natural; E : Bits_20); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_20; diff --git a/gcc/ada/s-pack21.adb b/gcc/ada/s-pack21.adb new file mode 100644 index 00000000000..d29d6624541 --- /dev/null +++ b/gcc/ada/s-pack21.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 1 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_21 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_21; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_21 -- + ------------ + + function Get_21 (Arr : System.Address; N : Natural) return Bits_21 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_21; + + ------------ + -- Set_21 -- + ------------ + + procedure Set_21 (Arr : System.Address; N : Natural; E : Bits_21) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_21; + +end System.Pack_21; diff --git a/gcc/ada/s-pack21.ads b/gcc/ada/s-pack21.ads new file mode 100644 index 00000000000..46d1d530109 --- /dev/null +++ b/gcc/ada/s-pack21.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 1 -- +-- -- +-- 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-2107, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 21 + +package System.Pack_21 is +pragma Preelaborate (Pack_21); + + Bits : constant := 21; + + type Bits_21 is mod 2 ** Bits; + for Bits_21'Size use Bits; + + function Get_21 (Arr : System.Address; N : Natural) return Bits_21; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_21 (Arr : System.Address; N : Natural; E : Bits_21); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_21; diff --git a/gcc/ada/s-pack22.adb b/gcc/ada/s-pack22.adb new file mode 100644 index 00000000000..e405a74a5cc --- /dev/null +++ b/gcc/ada/s-pack22.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 2 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_22 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_22; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_22 or SetU_22 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_22 -- + ------------ + + function Get_22 (Arr : System.Address; N : Natural) return Bits_22 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_22; + + ------------- + -- GetU_22 -- + ------------- + + function GetU_22 (Arr : System.Address; N : Natural) return Bits_22 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_22; + + ------------ + -- Set_22 -- + ------------ + + procedure Set_22 (Arr : System.Address; N : Natural; E : Bits_22) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_22; + + ------------- + -- SetU_22 -- + ------------- + + procedure SetU_22 (Arr : System.Address; N : Natural; E : Bits_22) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_22; + +end System.Pack_22; diff --git a/gcc/ada/s-pack22.ads b/gcc/ada/s-pack22.ads new file mode 100644 index 00000000000..42872b4c948 --- /dev/null +++ b/gcc/ada/s-pack22.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 2 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 22 + +package System.Pack_22 is +pragma Preelaborate (Pack_22); + + Bits : constant := 22; + + type Bits_22 is mod 2 ** Bits; + for Bits_22'Size use Bits; + + function Get_22 (Arr : System.Address; N : Natural) return Bits_22; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_22 (Arr : System.Address; N : Natural; E : Bits_22); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_22 (Arr : System.Address; N : Natural) return Bits_22; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_22 (Arr : System.Address; N : Natural; E : Bits_22); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_22; diff --git a/gcc/ada/s-pack23.adb b/gcc/ada/s-pack23.adb new file mode 100644 index 00000000000..e15445e3a64 --- /dev/null +++ b/gcc/ada/s-pack23.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_23 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_23; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_23 -- + ------------ + + function Get_23 (Arr : System.Address; N : Natural) return Bits_23 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_23; + + ------------ + -- Set_23 -- + ------------ + + procedure Set_23 (Arr : System.Address; N : Natural; E : Bits_23) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_23; + +end System.Pack_23; diff --git a/gcc/ada/s-pack23.ads b/gcc/ada/s-pack23.ads new file mode 100644 index 00000000000..5e3c6ceed8e --- /dev/null +++ b/gcc/ada/s-pack23.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 3 -- +-- -- +-- 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-2307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 23 + +package System.Pack_23 is +pragma Preelaborate (Pack_23); + + Bits : constant := 23; + + type Bits_23 is mod 2 ** Bits; + for Bits_23'Size use Bits; + + function Get_23 (Arr : System.Address; N : Natural) return Bits_23; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_23 (Arr : System.Address; N : Natural; E : Bits_23); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_23; diff --git a/gcc/ada/s-pack24.adb b/gcc/ada/s-pack24.adb new file mode 100644 index 00000000000..26e37f5cf57 --- /dev/null +++ b/gcc/ada/s-pack24.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 4 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_24 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_24; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_24 or SetU_24 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_24 -- + ------------ + + function Get_24 (Arr : System.Address; N : Natural) return Bits_24 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_24; + + ------------- + -- GetU_24 -- + ------------- + + function GetU_24 (Arr : System.Address; N : Natural) return Bits_24 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_24; + + ------------ + -- Set_24 -- + ------------ + + procedure Set_24 (Arr : System.Address; N : Natural; E : Bits_24) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_24; + + ------------- + -- SetU_24 -- + ------------- + + procedure SetU_24 (Arr : System.Address; N : Natural; E : Bits_24) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_24; + +end System.Pack_24; diff --git a/gcc/ada/s-pack24.ads b/gcc/ada/s-pack24.ads new file mode 100644 index 00000000000..e315f8c1f61 --- /dev/null +++ b/gcc/ada/s-pack24.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 4 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 24 + +package System.Pack_24 is +pragma Preelaborate (Pack_24); + + Bits : constant := 24; + + type Bits_24 is mod 2 ** Bits; + for Bits_24'Size use Bits; + + function Get_24 (Arr : System.Address; N : Natural) return Bits_24; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_24 (Arr : System.Address; N : Natural; E : Bits_24); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_24 (Arr : System.Address; N : Natural) return Bits_24; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_24 (Arr : System.Address; N : Natural; E : Bits_24); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_24; diff --git a/gcc/ada/s-pack25.adb b/gcc/ada/s-pack25.adb new file mode 100644 index 00000000000..e9399ad69c6 --- /dev/null +++ b/gcc/ada/s-pack25.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_25 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_25; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_25 -- + ------------ + + function Get_25 (Arr : System.Address; N : Natural) return Bits_25 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_25; + + ------------ + -- Set_25 -- + ------------ + + procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_25; + +end System.Pack_25; diff --git a/gcc/ada/s-pack25.ads b/gcc/ada/s-pack25.ads new file mode 100644 index 00000000000..2abc74716a6 --- /dev/null +++ b/gcc/ada/s-pack25.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 5 -- +-- -- +-- 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-2507, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 25 + +package System.Pack_25 is +pragma Preelaborate (Pack_25); + + Bits : constant := 25; + + type Bits_25 is mod 2 ** Bits; + for Bits_25'Size use Bits; + + function Get_25 (Arr : System.Address; N : Natural) return Bits_25; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_25; diff --git a/gcc/ada/s-pack26.adb b/gcc/ada/s-pack26.adb new file mode 100644 index 00000000000..c3af1491c40 --- /dev/null +++ b/gcc/ada/s-pack26.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 6 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_26 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_26; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_26 or SetU_26 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_26 -- + ------------ + + function Get_26 (Arr : System.Address; N : Natural) return Bits_26 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_26; + + ------------- + -- GetU_26 -- + ------------- + + function GetU_26 (Arr : System.Address; N : Natural) return Bits_26 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_26; + + ------------ + -- Set_26 -- + ------------ + + procedure Set_26 (Arr : System.Address; N : Natural; E : Bits_26) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_26; + + ------------- + -- SetU_26 -- + ------------- + + procedure SetU_26 (Arr : System.Address; N : Natural; E : Bits_26) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_26; + +end System.Pack_26; diff --git a/gcc/ada/s-pack26.ads b/gcc/ada/s-pack26.ads new file mode 100644 index 00000000000..fc9a05aa165 --- /dev/null +++ b/gcc/ada/s-pack26.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 6 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 26 + +package System.Pack_26 is +pragma Preelaborate (Pack_26); + + Bits : constant := 26; + + type Bits_26 is mod 2 ** Bits; + for Bits_26'Size use Bits; + + function Get_26 (Arr : System.Address; N : Natural) return Bits_26; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_26 (Arr : System.Address; N : Natural; E : Bits_26); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_26 (Arr : System.Address; N : Natural) return Bits_26; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_26 (Arr : System.Address; N : Natural; E : Bits_26); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_26; diff --git a/gcc/ada/s-pack27.adb b/gcc/ada/s-pack27.adb new file mode 100644 index 00000000000..a637f9212d8 --- /dev/null +++ b/gcc/ada/s-pack27.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 7 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_27 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_27; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_27 -- + ------------ + + function Get_27 (Arr : System.Address; N : Natural) return Bits_27 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_27; + + ------------ + -- Set_27 -- + ------------ + + procedure Set_27 (Arr : System.Address; N : Natural; E : Bits_27) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_27; + +end System.Pack_27; diff --git a/gcc/ada/s-pack27.ads b/gcc/ada/s-pack27.ads new file mode 100644 index 00000000000..28d1b57740a --- /dev/null +++ b/gcc/ada/s-pack27.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 7 -- +-- -- +-- 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-2707, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 27 + +package System.Pack_27 is +pragma Preelaborate (Pack_27); + + Bits : constant := 27; + + type Bits_27 is mod 2 ** Bits; + for Bits_27'Size use Bits; + + function Get_27 (Arr : System.Address; N : Natural) return Bits_27; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_27 (Arr : System.Address; N : Natural; E : Bits_27); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_27; diff --git a/gcc/ada/s-pack28.adb b/gcc/ada/s-pack28.adb new file mode 100644 index 00000000000..84afb9afacd --- /dev/null +++ b/gcc/ada/s-pack28.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 8 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_28 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_28; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_28 or SetU_28 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_28 -- + ------------ + + function Get_28 (Arr : System.Address; N : Natural) return Bits_28 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_28; + + ------------- + -- GetU_28 -- + ------------- + + function GetU_28 (Arr : System.Address; N : Natural) return Bits_28 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_28; + + ------------ + -- Set_28 -- + ------------ + + procedure Set_28 (Arr : System.Address; N : Natural; E : Bits_28) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_28; + + ------------- + -- SetU_28 -- + ------------- + + procedure SetU_28 (Arr : System.Address; N : Natural; E : Bits_28) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_28; + +end System.Pack_28; diff --git a/gcc/ada/s-pack28.ads b/gcc/ada/s-pack28.ads new file mode 100644 index 00000000000..125321e28df --- /dev/null +++ b/gcc/ada/s-pack28.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 8 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 28 + +package System.Pack_28 is +pragma Preelaborate (Pack_28); + + Bits : constant := 28; + + type Bits_28 is mod 2 ** Bits; + for Bits_28'Size use Bits; + + function Get_28 (Arr : System.Address; N : Natural) return Bits_28; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_28 (Arr : System.Address; N : Natural; E : Bits_28); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_28 (Arr : System.Address; N : Natural) return Bits_28; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_28 (Arr : System.Address; N : Natural; E : Bits_28); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_28; diff --git a/gcc/ada/s-pack29.adb b/gcc/ada/s-pack29.adb new file mode 100644 index 00000000000..5b5792b52c8 --- /dev/null +++ b/gcc/ada/s-pack29.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 9 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_29 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_29; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_29 -- + ------------ + + function Get_29 (Arr : System.Address; N : Natural) return Bits_29 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_29; + + ------------ + -- Set_29 -- + ------------ + + procedure Set_29 (Arr : System.Address; N : Natural; E : Bits_29) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_29; + +end System.Pack_29; diff --git a/gcc/ada/s-pack29.ads b/gcc/ada/s-pack29.ads new file mode 100644 index 00000000000..dcd20fae239 --- /dev/null +++ b/gcc/ada/s-pack29.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 9 -- +-- -- +-- 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-2907, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 29 + +package System.Pack_29 is +pragma Preelaborate (Pack_29); + + Bits : constant := 29; + + type Bits_29 is mod 2 ** Bits; + for Bits_29'Size use Bits; + + function Get_29 (Arr : System.Address; N : Natural) return Bits_29; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_29 (Arr : System.Address; N : Natural; E : Bits_29); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_29; diff --git a/gcc/ada/s-pack30.adb b/gcc/ada/s-pack30.adb new file mode 100644 index 00000000000..b493250e05a --- /dev/null +++ b/gcc/ada/s-pack30.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 0 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_30 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_30; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_30 or SetU_30 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_30 -- + ------------ + + function Get_30 (Arr : System.Address; N : Natural) return Bits_30 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_30; + + ------------- + -- GetU_30 -- + ------------- + + function GetU_30 (Arr : System.Address; N : Natural) return Bits_30 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_30; + + ------------ + -- Set_30 -- + ------------ + + procedure Set_30 (Arr : System.Address; N : Natural; E : Bits_30) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_30; + + ------------- + -- SetU_30 -- + ------------- + + procedure SetU_30 (Arr : System.Address; N : Natural; E : Bits_30) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_30; + +end System.Pack_30; diff --git a/gcc/ada/s-pack30.ads b/gcc/ada/s-pack30.ads new file mode 100644 index 00000000000..77714a54194 --- /dev/null +++ b/gcc/ada/s-pack30.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 0 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 30 + +package System.Pack_30 is +pragma Preelaborate (Pack_30); + + Bits : constant := 30; + + type Bits_30 is mod 2 ** Bits; + for Bits_30'Size use Bits; + + function Get_30 (Arr : System.Address; N : Natural) return Bits_30; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_30 (Arr : System.Address; N : Natural; E : Bits_30); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_30 (Arr : System.Address; N : Natural) return Bits_30; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_30 (Arr : System.Address; N : Natural; E : Bits_30); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_30; diff --git a/gcc/ada/s-pack31.adb b/gcc/ada/s-pack31.adb new file mode 100644 index 00000000000..cb7ec025d27 --- /dev/null +++ b/gcc/ada/s-pack31.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 1 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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 System.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_31 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_31; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_31 -- + ------------ + + function Get_31 (Arr : System.Address; N : Natural) return Bits_31 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_31; + + ------------ + -- Set_31 -- + ------------ + + procedure Set_31 (Arr : System.Address; N : Natural; E : Bits_31) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_31; + +end System.Pack_31; diff --git a/gcc/ada/s-pack31.ads b/gcc/ada/s-pack31.ads new file mode 100644 index 00000000000..ab084ae392d --- /dev/null +++ b/gcc/ada/s-pack31.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 1 -- +-- -- +-- 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-3107, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 31 + +package System.Pack_31 is +pragma Preelaborate (Pack_31); + + Bits : constant := 31; + + type Bits_31 is mod 2 ** Bits; + for Bits_31'Size use Bits; + + function Get_31 (Arr : System.Address; N : Natural) return Bits_31; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_31 (Arr : System.Address; N : Natural; E : Bits_31); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_31; diff --git a/gcc/ada/s-pack33.adb b/gcc/ada/s-pack33.adb new file mode 100644 index 00000000000..d5f7972c3de --- /dev/null +++ b/gcc/ada/s-pack33.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 3 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_33 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_33; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_33 -- + ------------ + + function Get_33 (Arr : System.Address; N : Natural) return Bits_33 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_33; + + ------------ + -- Set_33 -- + ------------ + + procedure Set_33 (Arr : System.Address; N : Natural; E : Bits_33) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_33; + +end System.Pack_33; diff --git a/gcc/ada/s-pack33.ads b/gcc/ada/s-pack33.ads new file mode 100644 index 00000000000..1c3bb2576f8 --- /dev/null +++ b/gcc/ada/s-pack33.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 3 -- +-- -- +-- 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-3307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 33 + +package System.Pack_33 is +pragma Preelaborate (Pack_33); + + Bits : constant := 33; + + type Bits_33 is mod 2 ** Bits; + for Bits_33'Size use Bits; + + function Get_33 (Arr : System.Address; N : Natural) return Bits_33; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_33 (Arr : System.Address; N : Natural; E : Bits_33); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_33; diff --git a/gcc/ada/s-pack34.adb b/gcc/ada/s-pack34.adb new file mode 100644 index 00000000000..291b6958b27 --- /dev/null +++ b/gcc/ada/s-pack34.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 4 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_34 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_34; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_34 or SetU_34 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_34 -- + ------------ + + function Get_34 (Arr : System.Address; N : Natural) return Bits_34 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_34; + + ------------- + -- GetU_34 -- + ------------- + + function GetU_34 (Arr : System.Address; N : Natural) return Bits_34 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_34; + + ------------ + -- Set_34 -- + ------------ + + procedure Set_34 (Arr : System.Address; N : Natural; E : Bits_34) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_34; + + ------------- + -- SetU_34 -- + ------------- + + procedure SetU_34 (Arr : System.Address; N : Natural; E : Bits_34) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_34; + +end System.Pack_34; diff --git a/gcc/ada/s-pack34.ads b/gcc/ada/s-pack34.ads new file mode 100644 index 00000000000..17f35207927 --- /dev/null +++ b/gcc/ada/s-pack34.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 4 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 34 + +package System.Pack_34 is +pragma Preelaborate (Pack_34); + + Bits : constant := 34; + + type Bits_34 is mod 2 ** Bits; + for Bits_34'Size use Bits; + + function Get_34 (Arr : System.Address; N : Natural) return Bits_34; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_34 (Arr : System.Address; N : Natural; E : Bits_34); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_34 (Arr : System.Address; N : Natural) return Bits_34; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_34 (Arr : System.Address; N : Natural; E : Bits_34); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_34; diff --git a/gcc/ada/s-pack35.adb b/gcc/ada/s-pack35.adb new file mode 100644 index 00000000000..ef5a50b1e2e --- /dev/null +++ b/gcc/ada/s-pack35.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 5 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_35 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_35; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_35 -- + ------------ + + function Get_35 (Arr : System.Address; N : Natural) return Bits_35 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_35; + + ------------ + -- Set_35 -- + ------------ + + procedure Set_35 (Arr : System.Address; N : Natural; E : Bits_35) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_35; + +end System.Pack_35; diff --git a/gcc/ada/s-pack35.ads b/gcc/ada/s-pack35.ads new file mode 100644 index 00000000000..c1658f8ec97 --- /dev/null +++ b/gcc/ada/s-pack35.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 5 -- +-- -- +-- 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-3507, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 35 + +package System.Pack_35 is +pragma Preelaborate (Pack_35); + + Bits : constant := 35; + + type Bits_35 is mod 2 ** Bits; + for Bits_35'Size use Bits; + + function Get_35 (Arr : System.Address; N : Natural) return Bits_35; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_35 (Arr : System.Address; N : Natural; E : Bits_35); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_35; diff --git a/gcc/ada/s-pack36.adb b/gcc/ada/s-pack36.adb new file mode 100644 index 00000000000..f9a1d6bdda0 --- /dev/null +++ b/gcc/ada/s-pack36.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 6 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_36 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_36; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_36 or SetU_36 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_36 -- + ------------ + + function Get_36 (Arr : System.Address; N : Natural) return Bits_36 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_36; + + ------------- + -- GetU_36 -- + ------------- + + function GetU_36 (Arr : System.Address; N : Natural) return Bits_36 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_36; + + ------------ + -- Set_36 -- + ------------ + + procedure Set_36 (Arr : System.Address; N : Natural; E : Bits_36) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_36; + + ------------- + -- SetU_36 -- + ------------- + + procedure SetU_36 (Arr : System.Address; N : Natural; E : Bits_36) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_36; + +end System.Pack_36; diff --git a/gcc/ada/s-pack36.ads b/gcc/ada/s-pack36.ads new file mode 100644 index 00000000000..dc12fd3404a --- /dev/null +++ b/gcc/ada/s-pack36.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 6 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 36 + +package System.Pack_36 is +pragma Preelaborate (Pack_36); + + Bits : constant := 36; + + type Bits_36 is mod 2 ** Bits; + for Bits_36'Size use Bits; + + function Get_36 (Arr : System.Address; N : Natural) return Bits_36; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_36 (Arr : System.Address; N : Natural; E : Bits_36); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_36 (Arr : System.Address; N : Natural) return Bits_36; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_36 (Arr : System.Address; N : Natural; E : Bits_36); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_36; diff --git a/gcc/ada/s-pack37.adb b/gcc/ada/s-pack37.adb new file mode 100644 index 00000000000..42c4494e0e2 --- /dev/null +++ b/gcc/ada/s-pack37.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 7 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_37 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_37; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_37 -- + ------------ + + function Get_37 (Arr : System.Address; N : Natural) return Bits_37 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_37; + + ------------ + -- Set_37 -- + ------------ + + procedure Set_37 (Arr : System.Address; N : Natural; E : Bits_37) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_37; + +end System.Pack_37; diff --git a/gcc/ada/s-pack37.ads b/gcc/ada/s-pack37.ads new file mode 100644 index 00000000000..702d0f03798 --- /dev/null +++ b/gcc/ada/s-pack37.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 7 -- +-- -- +-- 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-3707, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 37 + +package System.Pack_37 is +pragma Preelaborate (Pack_37); + + Bits : constant := 37; + + type Bits_37 is mod 2 ** Bits; + for Bits_37'Size use Bits; + + function Get_37 (Arr : System.Address; N : Natural) return Bits_37; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_37 (Arr : System.Address; N : Natural; E : Bits_37); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_37; diff --git a/gcc/ada/s-pack38.adb b/gcc/ada/s-pack38.adb new file mode 100644 index 00000000000..71bc7d247bb --- /dev/null +++ b/gcc/ada/s-pack38.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 8 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_38 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_38; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_38 or SetU_38 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_38 -- + ------------ + + function Get_38 (Arr : System.Address; N : Natural) return Bits_38 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_38; + + ------------- + -- GetU_38 -- + ------------- + + function GetU_38 (Arr : System.Address; N : Natural) return Bits_38 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_38; + + ------------ + -- Set_38 -- + ------------ + + procedure Set_38 (Arr : System.Address; N : Natural; E : Bits_38) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_38; + + ------------- + -- SetU_38 -- + ------------- + + procedure SetU_38 (Arr : System.Address; N : Natural; E : Bits_38) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_38; + +end System.Pack_38; diff --git a/gcc/ada/s-pack38.ads b/gcc/ada/s-pack38.ads new file mode 100644 index 00000000000..4b68c9abd85 --- /dev/null +++ b/gcc/ada/s-pack38.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 8 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 38 + +package System.Pack_38 is +pragma Preelaborate (Pack_38); + + Bits : constant := 38; + + type Bits_38 is mod 2 ** Bits; + for Bits_38'Size use Bits; + + function Get_38 (Arr : System.Address; N : Natural) return Bits_38; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_38 (Arr : System.Address; N : Natural; E : Bits_38); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_38 (Arr : System.Address; N : Natural) return Bits_38; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_38 (Arr : System.Address; N : Natural; E : Bits_38); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_38; diff --git a/gcc/ada/s-pack39.adb b/gcc/ada/s-pack39.adb new file mode 100644 index 00000000000..5f813e3918a --- /dev/null +++ b/gcc/ada/s-pack39.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 9 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_39 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_39; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_39 -- + ------------ + + function Get_39 (Arr : System.Address; N : Natural) return Bits_39 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_39; + + ------------ + -- Set_39 -- + ------------ + + procedure Set_39 (Arr : System.Address; N : Natural; E : Bits_39) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_39; + +end System.Pack_39; diff --git a/gcc/ada/s-pack39.ads b/gcc/ada/s-pack39.ads new file mode 100644 index 00000000000..755a7a27048 --- /dev/null +++ b/gcc/ada/s-pack39.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 9 -- +-- -- +-- 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-3907, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 39 + +package System.Pack_39 is +pragma Preelaborate (Pack_39); + + Bits : constant := 39; + + type Bits_39 is mod 2 ** Bits; + for Bits_39'Size use Bits; + + function Get_39 (Arr : System.Address; N : Natural) return Bits_39; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_39 (Arr : System.Address; N : Natural; E : Bits_39); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_39; diff --git a/gcc/ada/s-pack40.adb b/gcc/ada/s-pack40.adb new file mode 100644 index 00000000000..1c9e598686f --- /dev/null +++ b/gcc/ada/s-pack40.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 0 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_40 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_40; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_40 or SetU_40 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_40 -- + ------------ + + function Get_40 (Arr : System.Address; N : Natural) return Bits_40 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_40; + + ------------- + -- GetU_40 -- + ------------- + + function GetU_40 (Arr : System.Address; N : Natural) return Bits_40 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_40; + + ------------ + -- Set_40 -- + ------------ + + procedure Set_40 (Arr : System.Address; N : Natural; E : Bits_40) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_40; + + ------------- + -- SetU_40 -- + ------------- + + procedure SetU_40 (Arr : System.Address; N : Natural; E : Bits_40) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_40; + +end System.Pack_40; diff --git a/gcc/ada/s-pack40.ads b/gcc/ada/s-pack40.ads new file mode 100644 index 00000000000..0258e504a15 --- /dev/null +++ b/gcc/ada/s-pack40.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 0 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 40 + +package System.Pack_40 is +pragma Preelaborate (Pack_40); + + Bits : constant := 40; + + type Bits_40 is mod 2 ** Bits; + for Bits_40'Size use Bits; + + function Get_40 (Arr : System.Address; N : Natural) return Bits_40; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_40 (Arr : System.Address; N : Natural; E : Bits_40); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_40 (Arr : System.Address; N : Natural) return Bits_40; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_40 (Arr : System.Address; N : Natural; E : Bits_40); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_40; diff --git a/gcc/ada/s-pack41.adb b/gcc/ada/s-pack41.adb new file mode 100644 index 00000000000..0997598c32d --- /dev/null +++ b/gcc/ada/s-pack41.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 1 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_41 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_41; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_41 -- + ------------ + + function Get_41 (Arr : System.Address; N : Natural) return Bits_41 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_41; + + ------------ + -- Set_41 -- + ------------ + + procedure Set_41 (Arr : System.Address; N : Natural; E : Bits_41) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_41; + +end System.Pack_41; diff --git a/gcc/ada/s-pack41.ads b/gcc/ada/s-pack41.ads new file mode 100644 index 00000000000..0de507ab415 --- /dev/null +++ b/gcc/ada/s-pack41.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 1 -- +-- -- +-- 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-4107, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 41 + +package System.Pack_41 is +pragma Preelaborate (Pack_41); + + Bits : constant := 41; + + type Bits_41 is mod 2 ** Bits; + for Bits_41'Size use Bits; + + function Get_41 (Arr : System.Address; N : Natural) return Bits_41; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_41 (Arr : System.Address; N : Natural; E : Bits_41); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_41; diff --git a/gcc/ada/s-pack42.adb b/gcc/ada/s-pack42.adb new file mode 100644 index 00000000000..2a2d393d877 --- /dev/null +++ b/gcc/ada/s-pack42.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 2 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_42 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_42; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_42 or SetU_42 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_42 -- + ------------ + + function Get_42 (Arr : System.Address; N : Natural) return Bits_42 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_42; + + ------------- + -- GetU_42 -- + ------------- + + function GetU_42 (Arr : System.Address; N : Natural) return Bits_42 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_42; + + ------------ + -- Set_42 -- + ------------ + + procedure Set_42 (Arr : System.Address; N : Natural; E : Bits_42) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_42; + + ------------- + -- SetU_42 -- + ------------- + + procedure SetU_42 (Arr : System.Address; N : Natural; E : Bits_42) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_42; + +end System.Pack_42; diff --git a/gcc/ada/s-pack42.ads b/gcc/ada/s-pack42.ads new file mode 100644 index 00000000000..971e147f475 --- /dev/null +++ b/gcc/ada/s-pack42.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 2 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 42 + +package System.Pack_42 is +pragma Preelaborate (Pack_42); + + Bits : constant := 42; + + type Bits_42 is mod 2 ** Bits; + for Bits_42'Size use Bits; + + function Get_42 (Arr : System.Address; N : Natural) return Bits_42; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_42 (Arr : System.Address; N : Natural; E : Bits_42); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_42 (Arr : System.Address; N : Natural) return Bits_42; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_42 (Arr : System.Address; N : Natural; E : Bits_42); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_42; diff --git a/gcc/ada/s-pack43.adb b/gcc/ada/s-pack43.adb new file mode 100644 index 00000000000..727feeb7cca --- /dev/null +++ b/gcc/ada/s-pack43.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 3 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_43 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_43; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_43 -- + ------------ + + function Get_43 (Arr : System.Address; N : Natural) return Bits_43 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_43; + + ------------ + -- Set_43 -- + ------------ + + procedure Set_43 (Arr : System.Address; N : Natural; E : Bits_43) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_43; + +end System.Pack_43; diff --git a/gcc/ada/s-pack43.ads b/gcc/ada/s-pack43.ads new file mode 100644 index 00000000000..bcc30f9230f --- /dev/null +++ b/gcc/ada/s-pack43.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 3 -- +-- -- +-- 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-4307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 43 + +package System.Pack_43 is +pragma Preelaborate (Pack_43); + + Bits : constant := 43; + + type Bits_43 is mod 2 ** Bits; + for Bits_43'Size use Bits; + + function Get_43 (Arr : System.Address; N : Natural) return Bits_43; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_43 (Arr : System.Address; N : Natural; E : Bits_43); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_43; diff --git a/gcc/ada/s-pack44.adb b/gcc/ada/s-pack44.adb new file mode 100644 index 00000000000..09bcba08109 --- /dev/null +++ b/gcc/ada/s-pack44.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 4 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_44 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_44; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_44 or SetU_44 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_44 -- + ------------ + + function Get_44 (Arr : System.Address; N : Natural) return Bits_44 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_44; + + ------------- + -- GetU_44 -- + ------------- + + function GetU_44 (Arr : System.Address; N : Natural) return Bits_44 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_44; + + ------------ + -- Set_44 -- + ------------ + + procedure Set_44 (Arr : System.Address; N : Natural; E : Bits_44) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_44; + + ------------- + -- SetU_44 -- + ------------- + + procedure SetU_44 (Arr : System.Address; N : Natural; E : Bits_44) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_44; + +end System.Pack_44; diff --git a/gcc/ada/s-pack44.ads b/gcc/ada/s-pack44.ads new file mode 100644 index 00000000000..84ef9c7cc1c --- /dev/null +++ b/gcc/ada/s-pack44.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 4 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 44 + +package System.Pack_44 is +pragma Preelaborate (Pack_44); + + Bits : constant := 44; + + type Bits_44 is mod 2 ** Bits; + for Bits_44'Size use Bits; + + function Get_44 (Arr : System.Address; N : Natural) return Bits_44; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_44 (Arr : System.Address; N : Natural; E : Bits_44); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_44 (Arr : System.Address; N : Natural) return Bits_44; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_44 (Arr : System.Address; N : Natural; E : Bits_44); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_44; diff --git a/gcc/ada/s-pack45.adb b/gcc/ada/s-pack45.adb new file mode 100644 index 00000000000..871940ec39d --- /dev/null +++ b/gcc/ada/s-pack45.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 5 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_45 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_45; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_45 -- + ------------ + + function Get_45 (Arr : System.Address; N : Natural) return Bits_45 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_45; + + ------------ + -- Set_45 -- + ------------ + + procedure Set_45 (Arr : System.Address; N : Natural; E : Bits_45) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_45; + +end System.Pack_45; diff --git a/gcc/ada/s-pack45.ads b/gcc/ada/s-pack45.ads new file mode 100644 index 00000000000..b2d1e296b8f --- /dev/null +++ b/gcc/ada/s-pack45.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 5 -- +-- -- +-- 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-4507, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 45 + +package System.Pack_45 is +pragma Preelaborate (Pack_45); + + Bits : constant := 45; + + type Bits_45 is mod 2 ** Bits; + for Bits_45'Size use Bits; + + function Get_45 (Arr : System.Address; N : Natural) return Bits_45; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_45 (Arr : System.Address; N : Natural; E : Bits_45); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_45; diff --git a/gcc/ada/s-pack46.adb b/gcc/ada/s-pack46.adb new file mode 100644 index 00000000000..c0d24cc505d --- /dev/null +++ b/gcc/ada/s-pack46.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 6 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_46 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_46; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_46 or SetU_46 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_46 -- + ------------ + + function Get_46 (Arr : System.Address; N : Natural) return Bits_46 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_46; + + ------------- + -- GetU_46 -- + ------------- + + function GetU_46 (Arr : System.Address; N : Natural) return Bits_46 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_46; + + ------------ + -- Set_46 -- + ------------ + + procedure Set_46 (Arr : System.Address; N : Natural; E : Bits_46) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_46; + + ------------- + -- SetU_46 -- + ------------- + + procedure SetU_46 (Arr : System.Address; N : Natural; E : Bits_46) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_46; + +end System.Pack_46; diff --git a/gcc/ada/s-pack46.ads b/gcc/ada/s-pack46.ads new file mode 100644 index 00000000000..2d688dd76fa --- /dev/null +++ b/gcc/ada/s-pack46.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 6 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 46 + +package System.Pack_46 is +pragma Preelaborate (Pack_46); + + Bits : constant := 46; + + type Bits_46 is mod 2 ** Bits; + for Bits_46'Size use Bits; + + function Get_46 (Arr : System.Address; N : Natural) return Bits_46; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_46 (Arr : System.Address; N : Natural; E : Bits_46); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_46 (Arr : System.Address; N : Natural) return Bits_46; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_46 (Arr : System.Address; N : Natural; E : Bits_46); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_46; diff --git a/gcc/ada/s-pack47.adb b/gcc/ada/s-pack47.adb new file mode 100644 index 00000000000..4d1b0fe0b2a --- /dev/null +++ b/gcc/ada/s-pack47.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 7 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_47 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_47; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_47 -- + ------------ + + function Get_47 (Arr : System.Address; N : Natural) return Bits_47 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_47; + + ------------ + -- Set_47 -- + ------------ + + procedure Set_47 (Arr : System.Address; N : Natural; E : Bits_47) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_47; + +end System.Pack_47; diff --git a/gcc/ada/s-pack47.ads b/gcc/ada/s-pack47.ads new file mode 100644 index 00000000000..b09d7ee9473 --- /dev/null +++ b/gcc/ada/s-pack47.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 7 -- +-- -- +-- 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-4707, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 47 + +package System.Pack_47 is +pragma Preelaborate (Pack_47); + + Bits : constant := 47; + + type Bits_47 is mod 2 ** Bits; + for Bits_47'Size use Bits; + + function Get_47 (Arr : System.Address; N : Natural) return Bits_47; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_47 (Arr : System.Address; N : Natural; E : Bits_47); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_47; diff --git a/gcc/ada/s-pack48.adb b/gcc/ada/s-pack48.adb new file mode 100644 index 00000000000..90d0d251f63 --- /dev/null +++ b/gcc/ada/s-pack48.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 8 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_48 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_48; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_48 or SetU_48 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_48 -- + ------------ + + function Get_48 (Arr : System.Address; N : Natural) return Bits_48 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_48; + + ------------- + -- GetU_48 -- + ------------- + + function GetU_48 (Arr : System.Address; N : Natural) return Bits_48 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_48; + + ------------ + -- Set_48 -- + ------------ + + procedure Set_48 (Arr : System.Address; N : Natural; E : Bits_48) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_48; + + ------------- + -- SetU_48 -- + ------------- + + procedure SetU_48 (Arr : System.Address; N : Natural; E : Bits_48) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_48; + +end System.Pack_48; diff --git a/gcc/ada/s-pack48.ads b/gcc/ada/s-pack48.ads new file mode 100644 index 00000000000..e4aa93502c1 --- /dev/null +++ b/gcc/ada/s-pack48.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 8 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 48 + +package System.Pack_48 is +pragma Preelaborate (Pack_48); + + Bits : constant := 48; + + type Bits_48 is mod 2 ** Bits; + for Bits_48'Size use Bits; + + function Get_48 (Arr : System.Address; N : Natural) return Bits_48; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_48 (Arr : System.Address; N : Natural; E : Bits_48); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_48 (Arr : System.Address; N : Natural) return Bits_48; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_48 (Arr : System.Address; N : Natural; E : Bits_48); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_48; diff --git a/gcc/ada/s-pack49.adb b/gcc/ada/s-pack49.adb new file mode 100644 index 00000000000..442131f18c1 --- /dev/null +++ b/gcc/ada/s-pack49.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 9 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_49 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_49; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_49 -- + ------------ + + function Get_49 (Arr : System.Address; N : Natural) return Bits_49 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_49; + + ------------ + -- Set_49 -- + ------------ + + procedure Set_49 (Arr : System.Address; N : Natural; E : Bits_49) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_49; + +end System.Pack_49; diff --git a/gcc/ada/s-pack49.ads b/gcc/ada/s-pack49.ads new file mode 100644 index 00000000000..fd25c5879fc --- /dev/null +++ b/gcc/ada/s-pack49.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 9 -- +-- -- +-- 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-4907, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 49 + +package System.Pack_49 is +pragma Preelaborate (Pack_49); + + Bits : constant := 49; + + type Bits_49 is mod 2 ** Bits; + for Bits_49'Size use Bits; + + function Get_49 (Arr : System.Address; N : Natural) return Bits_49; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_49 (Arr : System.Address; N : Natural; E : Bits_49); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_49; diff --git a/gcc/ada/s-pack50.adb b/gcc/ada/s-pack50.adb new file mode 100644 index 00000000000..e0bb450dda9 --- /dev/null +++ b/gcc/ada/s-pack50.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 0 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_50 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_50; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_50 or SetU_50 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_50 -- + ------------ + + function Get_50 (Arr : System.Address; N : Natural) return Bits_50 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_50; + + ------------- + -- GetU_50 -- + ------------- + + function GetU_50 (Arr : System.Address; N : Natural) return Bits_50 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_50; + + ------------ + -- Set_50 -- + ------------ + + procedure Set_50 (Arr : System.Address; N : Natural; E : Bits_50) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_50; + + ------------- + -- SetU_50 -- + ------------- + + procedure SetU_50 (Arr : System.Address; N : Natural; E : Bits_50) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_50; + +end System.Pack_50; diff --git a/gcc/ada/s-pack50.ads b/gcc/ada/s-pack50.ads new file mode 100644 index 00000000000..48f2eb1b29b --- /dev/null +++ b/gcc/ada/s-pack50.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 0 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 50 + +package System.Pack_50 is +pragma Preelaborate (Pack_50); + + Bits : constant := 50; + + type Bits_50 is mod 2 ** Bits; + for Bits_50'Size use Bits; + + function Get_50 (Arr : System.Address; N : Natural) return Bits_50; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_50 (Arr : System.Address; N : Natural; E : Bits_50); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_50 (Arr : System.Address; N : Natural) return Bits_50; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_50 (Arr : System.Address; N : Natural; E : Bits_50); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_50; diff --git a/gcc/ada/s-pack51.adb b/gcc/ada/s-pack51.adb new file mode 100644 index 00000000000..330f1627f58 --- /dev/null +++ b/gcc/ada/s-pack51.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 1 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_51 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_51; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_51 -- + ------------ + + function Get_51 (Arr : System.Address; N : Natural) return Bits_51 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_51; + + ------------ + -- Set_51 -- + ------------ + + procedure Set_51 (Arr : System.Address; N : Natural; E : Bits_51) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_51; + +end System.Pack_51; diff --git a/gcc/ada/s-pack51.ads b/gcc/ada/s-pack51.ads new file mode 100644 index 00000000000..c59e5ea3d1e --- /dev/null +++ b/gcc/ada/s-pack51.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 1 -- +-- -- +-- 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-5107, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 51 + +package System.Pack_51 is +pragma Preelaborate (Pack_51); + + Bits : constant := 51; + + type Bits_51 is mod 2 ** Bits; + for Bits_51'Size use Bits; + + function Get_51 (Arr : System.Address; N : Natural) return Bits_51; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_51 (Arr : System.Address; N : Natural; E : Bits_51); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_51; diff --git a/gcc/ada/s-pack52.adb b/gcc/ada/s-pack52.adb new file mode 100644 index 00000000000..91ee440f411 --- /dev/null +++ b/gcc/ada/s-pack52.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 2 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_52 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_52; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_52 or SetU_52 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_52 -- + ------------ + + function Get_52 (Arr : System.Address; N : Natural) return Bits_52 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_52; + + ------------- + -- GetU_52 -- + ------------- + + function GetU_52 (Arr : System.Address; N : Natural) return Bits_52 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_52; + + ------------ + -- Set_52 -- + ------------ + + procedure Set_52 (Arr : System.Address; N : Natural; E : Bits_52) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_52; + + ------------- + -- SetU_52 -- + ------------- + + procedure SetU_52 (Arr : System.Address; N : Natural; E : Bits_52) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_52; + +end System.Pack_52; diff --git a/gcc/ada/s-pack52.ads b/gcc/ada/s-pack52.ads new file mode 100644 index 00000000000..10264dfaab9 --- /dev/null +++ b/gcc/ada/s-pack52.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 2 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 52 + +package System.Pack_52 is +pragma Preelaborate (Pack_52); + + Bits : constant := 52; + + type Bits_52 is mod 2 ** Bits; + for Bits_52'Size use Bits; + + function Get_52 (Arr : System.Address; N : Natural) return Bits_52; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_52 (Arr : System.Address; N : Natural; E : Bits_52); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_52 (Arr : System.Address; N : Natural) return Bits_52; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_52 (Arr : System.Address; N : Natural; E : Bits_52); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_52; diff --git a/gcc/ada/s-pack53.adb b/gcc/ada/s-pack53.adb new file mode 100644 index 00000000000..ff56f075839 --- /dev/null +++ b/gcc/ada/s-pack53.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 3 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_53 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_53; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_53 -- + ------------ + + function Get_53 (Arr : System.Address; N : Natural) return Bits_53 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_53; + + ------------ + -- Set_53 -- + ------------ + + procedure Set_53 (Arr : System.Address; N : Natural; E : Bits_53) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_53; + +end System.Pack_53; diff --git a/gcc/ada/s-pack53.ads b/gcc/ada/s-pack53.ads new file mode 100644 index 00000000000..e9e2b8a8536 --- /dev/null +++ b/gcc/ada/s-pack53.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 3 -- +-- -- +-- 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-5307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 53 + +package System.Pack_53 is +pragma Preelaborate (Pack_53); + + Bits : constant := 53; + + type Bits_53 is mod 2 ** Bits; + for Bits_53'Size use Bits; + + function Get_53 (Arr : System.Address; N : Natural) return Bits_53; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_53 (Arr : System.Address; N : Natural; E : Bits_53); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_53; diff --git a/gcc/ada/s-pack54.adb b/gcc/ada/s-pack54.adb new file mode 100644 index 00000000000..d389e399954 --- /dev/null +++ b/gcc/ada/s-pack54.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 4 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_54 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_54; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_54 or SetU_54 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_54 -- + ------------ + + function Get_54 (Arr : System.Address; N : Natural) return Bits_54 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_54; + + ------------- + -- GetU_54 -- + ------------- + + function GetU_54 (Arr : System.Address; N : Natural) return Bits_54 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_54; + + ------------ + -- Set_54 -- + ------------ + + procedure Set_54 (Arr : System.Address; N : Natural; E : Bits_54) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_54; + + ------------- + -- SetU_54 -- + ------------- + + procedure SetU_54 (Arr : System.Address; N : Natural; E : Bits_54) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_54; + +end System.Pack_54; diff --git a/gcc/ada/s-pack54.ads b/gcc/ada/s-pack54.ads new file mode 100644 index 00000000000..7f1d4ebf598 --- /dev/null +++ b/gcc/ada/s-pack54.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 4 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 54 + +package System.Pack_54 is +pragma Preelaborate (Pack_54); + + Bits : constant := 54; + + type Bits_54 is mod 2 ** Bits; + for Bits_54'Size use Bits; + + function Get_54 (Arr : System.Address; N : Natural) return Bits_54; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_54 (Arr : System.Address; N : Natural; E : Bits_54); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_54 (Arr : System.Address; N : Natural) return Bits_54; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_54 (Arr : System.Address; N : Natural; E : Bits_54); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_54; diff --git a/gcc/ada/s-pack55.adb b/gcc/ada/s-pack55.adb new file mode 100644 index 00000000000..e353ed4338f --- /dev/null +++ b/gcc/ada/s-pack55.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 5 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_55 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_55; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_55 -- + ------------ + + function Get_55 (Arr : System.Address; N : Natural) return Bits_55 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_55; + + ------------ + -- Set_55 -- + ------------ + + procedure Set_55 (Arr : System.Address; N : Natural; E : Bits_55) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_55; + +end System.Pack_55; diff --git a/gcc/ada/s-pack55.ads b/gcc/ada/s-pack55.ads new file mode 100644 index 00000000000..68b0aaad3c5 --- /dev/null +++ b/gcc/ada/s-pack55.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 5 -- +-- -- +-- 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-5507, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 55 + +package System.Pack_55 is +pragma Preelaborate (Pack_55); + + Bits : constant := 55; + + type Bits_55 is mod 2 ** Bits; + for Bits_55'Size use Bits; + + function Get_55 (Arr : System.Address; N : Natural) return Bits_55; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_55 (Arr : System.Address; N : Natural; E : Bits_55); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_55; diff --git a/gcc/ada/s-pack56.adb b/gcc/ada/s-pack56.adb new file mode 100644 index 00000000000..4300bd6230c --- /dev/null +++ b/gcc/ada/s-pack56.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 6 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_56 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_56; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_56 or SetU_56 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_56 -- + ------------ + + function Get_56 (Arr : System.Address; N : Natural) return Bits_56 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_56; + + ------------- + -- GetU_56 -- + ------------- + + function GetU_56 (Arr : System.Address; N : Natural) return Bits_56 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_56; + + ------------ + -- Set_56 -- + ------------ + + procedure Set_56 (Arr : System.Address; N : Natural; E : Bits_56) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_56; + + ------------- + -- SetU_56 -- + ------------- + + procedure SetU_56 (Arr : System.Address; N : Natural; E : Bits_56) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_56; + +end System.Pack_56; diff --git a/gcc/ada/s-pack56.ads b/gcc/ada/s-pack56.ads new file mode 100644 index 00000000000..94ae0a51b1b --- /dev/null +++ b/gcc/ada/s-pack56.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 6 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 56 + +package System.Pack_56 is +pragma Preelaborate (Pack_56); + + Bits : constant := 56; + + type Bits_56 is mod 2 ** Bits; + for Bits_56'Size use Bits; + + function Get_56 (Arr : System.Address; N : Natural) return Bits_56; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_56 (Arr : System.Address; N : Natural; E : Bits_56); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_56 (Arr : System.Address; N : Natural) return Bits_56; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_56 (Arr : System.Address; N : Natural; E : Bits_56); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_56; diff --git a/gcc/ada/s-pack57.adb b/gcc/ada/s-pack57.adb new file mode 100644 index 00000000000..077124e9a38 --- /dev/null +++ b/gcc/ada/s-pack57.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 7 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_57 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_57; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_57 -- + ------------ + + function Get_57 (Arr : System.Address; N : Natural) return Bits_57 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_57; + + ------------ + -- Set_57 -- + ------------ + + procedure Set_57 (Arr : System.Address; N : Natural; E : Bits_57) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_57; + +end System.Pack_57; diff --git a/gcc/ada/s-pack57.ads b/gcc/ada/s-pack57.ads new file mode 100644 index 00000000000..ab5f137c77e --- /dev/null +++ b/gcc/ada/s-pack57.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 7 -- +-- -- +-- 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-5707, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 57 + +package System.Pack_57 is +pragma Preelaborate (Pack_57); + + Bits : constant := 57; + + type Bits_57 is mod 2 ** Bits; + for Bits_57'Size use Bits; + + function Get_57 (Arr : System.Address; N : Natural) return Bits_57; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_57 (Arr : System.Address; N : Natural; E : Bits_57); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_57; diff --git a/gcc/ada/s-pack58.adb b/gcc/ada/s-pack58.adb new file mode 100644 index 00000000000..69011dc7325 --- /dev/null +++ b/gcc/ada/s-pack58.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 8 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_58 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_58; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_58 or SetU_58 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_58 -- + ------------ + + function Get_58 (Arr : System.Address; N : Natural) return Bits_58 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_58; + + ------------- + -- GetU_58 -- + ------------- + + function GetU_58 (Arr : System.Address; N : Natural) return Bits_58 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_58; + + ------------ + -- Set_58 -- + ------------ + + procedure Set_58 (Arr : System.Address; N : Natural; E : Bits_58) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_58; + + ------------- + -- SetU_58 -- + ------------- + + procedure SetU_58 (Arr : System.Address; N : Natural; E : Bits_58) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_58; + +end System.Pack_58; diff --git a/gcc/ada/s-pack58.ads b/gcc/ada/s-pack58.ads new file mode 100644 index 00000000000..debfb18faaa --- /dev/null +++ b/gcc/ada/s-pack58.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 8 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 58 + +package System.Pack_58 is +pragma Preelaborate (Pack_58); + + Bits : constant := 58; + + type Bits_58 is mod 2 ** Bits; + for Bits_58'Size use Bits; + + function Get_58 (Arr : System.Address; N : Natural) return Bits_58; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_58 (Arr : System.Address; N : Natural; E : Bits_58); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_58 (Arr : System.Address; N : Natural) return Bits_58; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_58 (Arr : System.Address; N : Natural; E : Bits_58); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_58; diff --git a/gcc/ada/s-pack59.adb b/gcc/ada/s-pack59.adb new file mode 100644 index 00000000000..fdfd208c635 --- /dev/null +++ b/gcc/ada/s-pack59.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 9 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_59 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_59; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_59 -- + ------------ + + function Get_59 (Arr : System.Address; N : Natural) return Bits_59 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_59; + + ------------ + -- Set_59 -- + ------------ + + procedure Set_59 (Arr : System.Address; N : Natural; E : Bits_59) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_59; + +end System.Pack_59; diff --git a/gcc/ada/s-pack59.ads b/gcc/ada/s-pack59.ads new file mode 100644 index 00000000000..2cfa7539282 --- /dev/null +++ b/gcc/ada/s-pack59.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 9 -- +-- -- +-- 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-5907, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 59 + +package System.Pack_59 is +pragma Preelaborate (Pack_59); + + Bits : constant := 59; + + type Bits_59 is mod 2 ** Bits; + for Bits_59'Size use Bits; + + function Get_59 (Arr : System.Address; N : Natural) return Bits_59; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_59 (Arr : System.Address; N : Natural; E : Bits_59); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_59; diff --git a/gcc/ada/s-pack60.adb b/gcc/ada/s-pack60.adb new file mode 100644 index 00000000000..49771ff4f44 --- /dev/null +++ b/gcc/ada/s-pack60.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 0 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_60 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_60; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_60 or SetU_60 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_60 -- + ------------ + + function Get_60 (Arr : System.Address; N : Natural) return Bits_60 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_60; + + ------------- + -- GetU_60 -- + ------------- + + function GetU_60 (Arr : System.Address; N : Natural) return Bits_60 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_60; + + ------------ + -- Set_60 -- + ------------ + + procedure Set_60 (Arr : System.Address; N : Natural; E : Bits_60) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_60; + + ------------- + -- SetU_60 -- + ------------- + + procedure SetU_60 (Arr : System.Address; N : Natural; E : Bits_60) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_60; + +end System.Pack_60; diff --git a/gcc/ada/s-pack60.ads b/gcc/ada/s-pack60.ads new file mode 100644 index 00000000000..e795f355956 --- /dev/null +++ b/gcc/ada/s-pack60.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 0 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 60 + +package System.Pack_60 is +pragma Preelaborate (Pack_60); + + Bits : constant := 60; + + type Bits_60 is mod 2 ** Bits; + for Bits_60'Size use Bits; + + function Get_60 (Arr : System.Address; N : Natural) return Bits_60; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_60 (Arr : System.Address; N : Natural; E : Bits_60); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_60 (Arr : System.Address; N : Natural) return Bits_60; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_60 (Arr : System.Address; N : Natural; E : Bits_60); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_60; diff --git a/gcc/ada/s-pack61.adb b/gcc/ada/s-pack61.adb new file mode 100644 index 00000000000..fb90abd68b5 --- /dev/null +++ b/gcc/ada/s-pack61.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 1 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_61 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_61; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_61 -- + ------------ + + function Get_61 (Arr : System.Address; N : Natural) return Bits_61 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_61; + + ------------ + -- Set_61 -- + ------------ + + procedure Set_61 (Arr : System.Address; N : Natural; E : Bits_61) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_61; + +end System.Pack_61; diff --git a/gcc/ada/s-pack61.ads b/gcc/ada/s-pack61.ads new file mode 100644 index 00000000000..f9138fd942c --- /dev/null +++ b/gcc/ada/s-pack61.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 1 -- +-- -- +-- 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-6107, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 61 + +package System.Pack_61 is +pragma Preelaborate (Pack_61); + + Bits : constant := 61; + + type Bits_61 is mod 2 ** Bits; + for Bits_61'Size use Bits; + + function Get_61 (Arr : System.Address; N : Natural) return Bits_61; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_61 (Arr : System.Address; N : Natural; E : Bits_61); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_61; diff --git a/gcc/ada/s-pack62.adb b/gcc/ada/s-pack62.adb new file mode 100644 index 00000000000..31e3dafae77 --- /dev/null +++ b/gcc/ada/s-pack62.adb @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 2 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_62 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_62; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + -- The following declarations are for the case where the address + -- passed to GetU_62 or SetU_62 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + function To_Ref is new + Unchecked_Conversion (System.Address, ClusterU_Ref); + + ------------ + -- Get_62 -- + ------------ + + function Get_62 (Arr : System.Address; N : Natural) return Bits_62 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_62; + + ------------- + -- GetU_62 -- + ------------- + + function GetU_62 (Arr : System.Address; N : Natural) return Bits_62 is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end GetU_62; + + ------------ + -- Set_62 -- + ------------ + + procedure Set_62 (Arr : System.Address; N : Natural; E : Bits_62) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_62; + + ------------- + -- SetU_62 -- + ------------- + + procedure SetU_62 (Arr : System.Address; N : Natural; E : Bits_62) is + C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end SetU_62; + +end System.Pack_62; diff --git a/gcc/ada/s-pack62.ads b/gcc/ada/s-pack62.ads new file mode 100644 index 00000000000..c4b85edbc62 --- /dev/null +++ b/gcc/ada/s-pack62.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 2 -- +-- -- +-- 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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 62 + +package System.Pack_62 is +pragma Preelaborate (Pack_62); + + Bits : constant := 62; + + type Bits_62 is mod 2 ** Bits; + for Bits_62'Size use Bits; + + function Get_62 (Arr : System.Address; N : Natural) return Bits_62; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_62 (Arr : System.Address; N : Natural; E : Bits_62); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_62 (Arr : System.Address; N : Natural) return Bits_62; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_62 (Arr : System.Address; N : Natural; E : Bits_62); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_62; diff --git a/gcc/ada/s-pack63.adb b/gcc/ada/s-pack63.adb new file mode 100644 index 00000000000..80043d61a08 --- /dev/null +++ b/gcc/ada/s-pack63.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 3 -- +-- -- +-- B o d y -- +-- -- +-- $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. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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.Storage_Elements; +with System.Unsigned_Types; +with Unchecked_Conversion; + +package body System.Pack_63 is + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_63; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + function To_Ref is new + Unchecked_Conversion (System.Address, Cluster_Ref); + + ------------ + -- Get_63 -- + ------------ + + function Get_63 (Arr : System.Address; N : Natural) return Bits_63 is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end Get_63; + + ------------ + -- Set_63 -- + ------------ + + procedure Set_63 (Arr : System.Address; N : Natural; E : Bits_63) is + C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + + begin + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end Set_63; + +end System.Pack_63; diff --git a/gcc/ada/s-pack63.ads b/gcc/ada/s-pack63.ads new file mode 100644 index 00000000000..2faa0d1ce52 --- /dev/null +++ b/gcc/ada/s-pack63.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 3 -- +-- -- +-- 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-6307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 63 + +package System.Pack_63 is +pragma Preelaborate (Pack_63); + + Bits : constant := 63; + + type Bits_63 is mod 2 ** Bits; + for Bits_63'Size use Bits; + + function Get_63 (Arr : System.Address; N : Natural) return Bits_63; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_63 (Arr : System.Address; N : Natural; E : Bits_63); + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_63; diff --git a/gcc/ada/s-parame.adb b/gcc/ada/s-parame.adb new file mode 100644 index 00000000000..a5583cc3d6c --- /dev/null +++ b/gcc/ada/s-parame.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1995-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 System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return 20 * 1024; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + return 8 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads new file mode 100644 index 00000000000..92028c17398 --- /dev/null +++ b/gcc/ada/s-parame.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.41 $ +-- -- +-- 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 is the default version used for all systems for which no special +-- target-specific version of this package is provided. + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is +pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + +end System.Parameters; diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb new file mode 100644 index 00000000000..4d8e80d2706 --- /dev/null +++ b/gcc/ada/s-parint.adb @@ -0,0 +1,303 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- (Dummy body for non-distributed case) -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1995-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. -- +-- -- +-- GNAT 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 System.Partition_Interface is + + M : constant := 7; + + type String_Access is access String; + + -- To have a minimal implementation of U'Partition_ID. + + type Pkg_Node; + type Pkg_List is access Pkg_Node; + type Pkg_Node is record + Name : String_Access; + Next : Pkg_List; + end record; + + Pkg_Head : Pkg_List; + Pkg_Tail : Pkg_List; + + function getpid return Integer; + pragma Import (C, getpid); + + PID : constant Integer := getpid; + + function Lower (S : String) return String; + + Passive_Prefix : constant String := "SP__"; + -- String prepended in top of shared passive packages + + procedure Check + (Name : in Unit_Name; + Version : in String; + RCI : in Boolean := True) + is + begin + null; + end Check; + + ----------------------------- + -- Get_Active_Partition_Id -- + ----------------------------- + + function Get_Active_Partition_ID + (Name : Unit_Name) + return System.RPC.Partition_ID + is + P : Pkg_List := Pkg_Head; + N : String := Lower (Name); + + begin + while P /= null loop + if P.Name.all = N then + return Get_Local_Partition_ID; + end if; + + P := P.Next; + end loop; + + return M; + end Get_Active_Partition_ID; + + ------------------------ + -- Get_Active_Version -- + ------------------------ + + function Get_Active_Version + (Name : Unit_Name) + return String + is + begin + return ""; + end Get_Active_Version; + + ---------------------------- + -- Get_Local_Partition_Id -- + ---------------------------- + + function Get_Local_Partition_ID return System.RPC.Partition_ID is + begin + return System.RPC.Partition_ID (PID mod M); + end Get_Local_Partition_ID; + + ------------------------------ + -- Get_Passive_Partition_ID -- + ------------------------------ + + function Get_Passive_Partition_ID + (Name : Unit_Name) + return System.RPC.Partition_ID + is + begin + return Get_Local_Partition_ID; + end Get_Passive_Partition_ID; + + ------------------------- + -- Get_Passive_Version -- + ------------------------- + + function Get_Passive_Version + (Name : Unit_Name) + return String + is + begin + return ""; + end Get_Passive_Version; + + ------------------------------ + -- Get_RCI_Package_Receiver -- + ------------------------------ + + function Get_RCI_Package_Receiver + (Name : Unit_Name) + return Interfaces.Unsigned_64 + is + begin + return 0; + end Get_RCI_Package_Receiver; + + ------------------------------- + -- Get_Unique_Remote_Pointer -- + ------------------------------- + + procedure Get_Unique_Remote_Pointer + (Handler : in out RACW_Stub_Type_Access) + is + begin + null; + end Get_Unique_Remote_Pointer; + + ------------ + -- Launch -- + ------------ + + procedure Launch + (Rsh_Command : in String; + Name_Is_Host : in Boolean; + General_Name : in String; + Command_Line : in String) + is + begin + null; + end Launch; + + ----------- + -- Lower -- + ----------- + + function Lower (S : String) return String is + T : String := S; + + begin + for J in T'Range loop + if T (J) in 'A' .. 'Z' then + T (J) := Character'Val (Character'Pos (T (J)) - + Character'Pos ('A') + + Character'Pos ('a')); + end if; + end loop; + + return T; + end Lower; + + ------------------------------------ + -- Raise_Program_Error_For_E_4_18 -- + ------------------------------------ + + procedure Raise_Program_Error_For_E_4_18 is + begin + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, + "Illegal usage of remote access to class-wide type. See RM E.4(18)"); + end Raise_Program_Error_For_E_4_18; + + ------------------------------------- + -- Raise_Program_Error_Unknown_Tag -- + ------------------------------------- + + procedure Raise_Program_Error_Unknown_Tag + (E : in Ada.Exceptions.Exception_Occurrence) + is + begin + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, Ada.Exceptions.Exception_Message (E)); + end Raise_Program_Error_Unknown_Tag; + + -------------- + -- RCI_Info -- + -------------- + + package body RCI_Info is + + ----------------------------- + -- Get_Active_Partition_ID -- + ----------------------------- + + function Get_Active_Partition_ID return System.RPC.Partition_ID is + P : Pkg_List := Pkg_Head; + N : String := Lower (RCI_Name); + + begin + while P /= null loop + if P.Name.all = N then + return Get_Local_Partition_ID; + end if; + + P := P.Next; + end loop; + + return M; + end Get_Active_Partition_ID; + + ------------------------------ + -- Get_RCI_Package_Receiver -- + ------------------------------ + + function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is + begin + return 0; + end Get_RCI_Package_Receiver; + + end RCI_Info; + + ------------------------------ + -- Register_Passive_Package -- + ------------------------------ + + procedure Register_Passive_Package + (Name : in Unit_Name; + Version : in String := "") + is + begin + Register_Receiving_Stub (Passive_Prefix & Name, null, Version); + end Register_Passive_Package; + + ----------------------------- + -- Register_Receiving_Stub -- + ----------------------------- + + procedure Register_Receiving_Stub + (Name : in Unit_Name; + Receiver : in RPC.RPC_Receiver; + Version : in String := "") + is + begin + if Pkg_Tail = null then + Pkg_Head := new Pkg_Node'(new String'(Lower (Name)), null); + Pkg_Tail := Pkg_Head; + + else + Pkg_Tail.Next := new Pkg_Node'(new String'(Lower (Name)), null); + Pkg_Tail := Pkg_Tail.Next; + end if; + end Register_Receiving_Stub; + + --------- + -- Run -- + --------- + + procedure Run + (Main : in Main_Subprogram_Type := null) + is + begin + if Main /= null then + Main.all; + end if; + end Run; + +end System.Partition_Interface; diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads new file mode 100644 index 00000000000..f784583dbf0 --- /dev/null +++ b/gcc/ada/s-parint.ads @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1995-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. -- +-- -- +-- GNAT 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 Interfaces; +with System.RPC; + +package System.Partition_Interface is + + pragma Elaborate_Body; + + type Subprogram_Id is new Natural; + -- This type is used exclusively by stubs + + subtype Unit_Name is String; + -- Name of Ada units + + type Main_Subprogram_Type is access procedure; + + type RACW_Stub_Type is tagged record + Origin : RPC.Partition_ID; + Receiver : Interfaces.Unsigned_64; + Addr : Interfaces.Unsigned_64; + Asynchronous : Boolean; + end record; + type RACW_Stub_Type_Access is access RACW_Stub_Type; + -- This type is used by the expansion to implement distributed objects. + -- Do not change its definition or its layout without updating + -- exp_dist.adb. + + procedure Check + (Name : in Unit_Name; + Version : in String; + RCI : in Boolean := True); + -- Use by the main subprogram to check that a remote receiver + -- unit has has the same version than the caller's one. + + function Get_Active_Partition_ID + (Name : Unit_Name) + return RPC.Partition_ID; + -- Similar in some respects to RCI_Info.Get_Active_Partition_ID + + function Get_Active_Version + (Name : Unit_Name) + return String; + -- Similar in some respects to Get_Active_Partition_ID + + function Get_Local_Partition_ID return RPC.Partition_ID; + -- Return the Partition_ID of the current partition + + function Get_Passive_Partition_ID + (Name : Unit_Name) + return RPC.Partition_ID; + -- Return the Partition_ID of the given shared passive partition + + function Get_Passive_Version (Name : Unit_Name) return String; + -- Return the version corresponding to a shared passive unit + + function Get_RCI_Package_Receiver + (Name : Unit_Name) + return Interfaces.Unsigned_64; + -- Similar in some respects to RCI_Info.Get_RCI_Package_Receiver + + procedure Get_Unique_Remote_Pointer + (Handler : in out RACW_Stub_Type_Access); + -- Get a unique pointer on a remote object + + procedure Launch + (Rsh_Command : in String; + Name_Is_Host : in Boolean; + General_Name : in String; + Command_Line : in String); + -- General_Name represents the name of the machine or the name of the + -- partition (depending on the value of Name_Is_Host). Command_Line + -- holds the extra options that will be given on the command line. + -- Rsh_Command is typically "rsh", that will be used to launch the + -- other partition. + + procedure Raise_Program_Error_For_E_4_18; + pragma No_Return (Raise_Program_Error_For_E_4_18); + -- Raise Program_Error with an error message explaining why it has been + -- raised. The rule in E.4 (18) is tricky and misleading for most users + -- of the distributed systems annex. + + procedure Raise_Program_Error_Unknown_Tag + (E : in Ada.Exceptions.Exception_Occurrence); + pragma No_Return (Raise_Program_Error_Unknown_Tag); + -- Raise Program_Error with the same message as E one + + procedure Register_Receiving_Stub + (Name : in Unit_Name; + Receiver : in RPC.RPC_Receiver; + Version : in String := ""); + -- Register the fact that the Name receiving stub is now elaborated. + -- Register the access value to the package RPC_Receiver procedure. + + procedure Register_Passive_Package + (Name : in Unit_Name; + Version : in String := ""); + -- Register a passive package + + generic + RCI_Name : String; + package RCI_Info is + function Get_RCI_Package_Receiver return Interfaces.Unsigned_64; + function Get_Active_Partition_ID return RPC.Partition_ID; + end RCI_Info; + -- RCI package information caching + + procedure Run (Main : in Main_Subprogram_Type := null); + -- Run the main subprogram + +end System.Partition_Interface; diff --git a/gcc/ada/s-pooglo.adb b/gcc/ada/s-pooglo.adb new file mode 100644 index 00000000000..11f265eb1e3 --- /dev/null +++ b/gcc/ada/s-pooglo.adb @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ G L O B A 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Pools; use System.Storage_Pools; +with System.Storage_Elements; +with System.Memory; + +package body System.Pool_Global is + + package SSE renames System.Storage_Elements; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + Allocated : System.Address; + begin + Allocated := Memory.Alloc (Memory.size_t (Storage_Size)); + + -- The call to Alloc returns an address whose alignment is compatible + -- with the worst case alignment requirement for the machine; thus the + -- Alignment argument can be safely ignored. + + if Allocated = Null_Address then + raise Storage_Error; + else + Address := Allocated; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) is + begin + Memory.Free (Address); + end Deallocate; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size + (Pool : Unbounded_No_Reclaim_Pool) + return SSE.Storage_Count + is + begin + -- Intuitively, should return System.Memory_Size. But on Sun/Alsys, + -- System.Memory_Size > System.Max_Int, which means all you can do with + -- it is raise CONSTRAINT_ERROR... + + return SSE.Storage_Count'Last; + end Storage_Size; + +end System.Pool_Global; diff --git a/gcc/ada/s-pooglo.ads b/gcc/ada/s-pooglo.ads new file mode 100644 index 00000000000..c209e2d8da3 --- /dev/null +++ b/gcc/ada/s-pooglo.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ G L O B A L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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; +with System.Storage_Pools; +with System.Storage_Elements; + +package System.Pool_Global is + +pragma Elaborate_Body; +-- Needed to ensure that library routines can execute allocators + + -- Allocation strategy: + + -- Call to malloc/free for each Allocate/Deallocate + -- no user specifiable size + -- no automatic reclaim + -- minimal overhead + + -- Default pool in the compiler for access types globally declared + + type Unbounded_No_Reclaim_Pool is new + System.Storage_Pools.Root_Storage_Pool with null record; + + function Storage_Size + (Pool : Unbounded_No_Reclaim_Pool) + return System.Storage_Elements.Storage_Count; + + procedure Allocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Deallocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + -- Pool object for the compiler + + Global_Pool_Object : Unbounded_No_Reclaim_Pool; + +end System.Pool_Global; diff --git a/gcc/ada/s-pooloc.adb b/gcc/ada/s-pooloc.adb new file mode 100644 index 00000000000..6adbf2d33ca --- /dev/null +++ b/gcc/ada/s-pooloc.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ L O C A L -- +-- -- +-- 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 System.Memory; +with System.Storage_Elements; +with System.Address_To_Access_Conversions; + +package body System.Pool_Local is + + package SSE renames System.Storage_Elements; + use type SSE.Storage_Offset; + + Pointer_Size : constant SSE.Storage_Offset := Address'Size / Storage_Unit; + Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size; + + type Acc_Address is access all Address; + package Addr is new Address_To_Access_Conversions (Address); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Next (A : Address) return Acc_Address; + -- Given an address of a block, return an access to the next block + + function Prev (A : Address) return Acc_Address; + -- Given an address of a block, return an access to the previous block + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + Allocated : constant System.Address := + Memory.Alloc (Memory.size_t (Storage_Size + Pointers_Size)); + + begin + -- The call to Alloc returns an address whose alignment is compatible + -- with the worst case alignment requirement for the machine; thus the + -- Alignment argument can be safely ignored. + + if Allocated = Null_Address then + raise Storage_Error; + else + Address := Allocated + Pointers_Size; + Next (Allocated).all := Pool.First; + Prev (Allocated).all := Null_Address; + + if Pool.First /= Null_Address then + Prev (Pool.First).all := Allocated; + end if; + + Pool.First := Allocated; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + Allocated : constant System.Address := Address - Pointers_Size; + begin + if Prev (Allocated).all = Null_Address then + Pool.First := Next (Allocated).all; + Prev (Pool.First).all := Null_Address; + else + Next (Prev (Allocated).all).all := Next (Allocated).all; + end if; + + if Next (Allocated).all /= Null_Address then + Prev (Next (Allocated).all).all := Prev (Allocated).all; + end if; + + Memory.Free (Allocated); + end Deallocate; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Pool : in out Unbounded_Reclaim_Pool) is + N : System.Address := Pool.First; + Allocated : System.Address; + + begin + while N /= Null_Address loop + Allocated := N; + N := Next (N).all; + Memory.Free (Allocated); + end loop; + end Finalize; + + ---------- + -- Next -- + ---------- + + function Next (A : Address) return Acc_Address is + begin + return Acc_Address (Addr.To_Pointer (A)); + end Next; + + ---------- + -- Prev -- + ---------- + + function Prev (A : Address) return Acc_Address is + begin + return Acc_Address (Addr.To_Pointer (A + Pointer_Size)); + end Prev; + +end System.Pool_Local; diff --git a/gcc/ada/s-pooloc.ads b/gcc/ada/s-pooloc.ads new file mode 100644 index 00000000000..4a76a2a3de3 --- /dev/null +++ b/gcc/ada/s-pooloc.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ L O C A L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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 System.Storage_Elements; +with System.Pool_Global; + +package System.Pool_Local is + +pragma Elaborate_Body; +-- Needed to ensure that library routines can execute allocators + + ---------------------------- + -- Unbounded_Reclaim_Pool -- + ---------------------------- + + -- Allocation strategy: + + -- Call to malloc/free for each Allocate/Deallocate + -- no user specifiable size + -- Space of allocated objects is reclaimed at pool finalization + -- Manages a list of allocated objects + + -- Default pool in the compiler for access types locally declared + + type Unbounded_Reclaim_Pool is new + System.Pool_Global.Unbounded_No_Reclaim_Pool with + record + First : System.Address := Null_Address; + end record; + + -- function Storage_Size is inherited + + procedure Allocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Deallocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Finalize (Pool : in out Unbounded_Reclaim_Pool); + +end System.Pool_Local; diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb new file mode 100644 index 00000000000..fdcd93b1c27 --- /dev/null +++ b/gcc/ada/s-poosiz.adb @@ -0,0 +1,359 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ S I Z E -- +-- -- +-- 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 System.Storage_Elements; +with System.Address_To_Access_Conversions; + +package body System.Pool_Size is + + package SSE renames System.Storage_Elements; + use type SSE.Storage_Offset; + + package SC is new Address_To_Access_Conversions (SSE.Storage_Count); + + SC_Size : constant + := SSE.Storage_Count'Object_Size / System.Storage_Unit; + + package Variable_Size_Management is + + -- Embedded pool that manages allocation of variable-size data. + + -- This pool is used as soon as the Elmt_sizS of the pool object is 0. + + -- Allocation is done on the first chunk long enough for the request. + -- Deallocation just puts the freed chunk at the beginning of the list. + + procedure Initialize (Pool : in out Stack_Bounded_Pool); + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count); + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count); + end Variable_Size_Management; + + package Vsize renames Variable_Size_Management; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + begin + if Pool.Elmt_Size = 0 then + Vsize.Allocate (Pool, Address, Storage_Size, Alignment); + + elsif Pool.First_Free /= 0 then + Address := Pool.The_Pool (Pool.First_Free)'Address; + Pool.First_Free := SC.To_Pointer (Address).all; + + elsif + Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1) + then + Address := Pool.The_Pool (Pool.First_Empty)'Address; + Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size; + + else + raise Storage_Error; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + begin + if Pool.Elmt_Size = 0 then + Vsize.Deallocate (Pool, Address, Storage_Size, Alignment); + + else + SC.To_Pointer (Address).all := Pool.First_Free; + Pool.First_Free := Address - Pool.The_Pool'Address + 1; + end if; + end Deallocate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Pool : in out Stack_Bounded_Pool) is + Align : constant SSE.Storage_Count := + SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, Pool.Alignment); + + begin + if Pool.Elmt_Size = 0 then + Vsize.Initialize (Pool); + + else + Pool.First_Free := 0; + Pool.First_Empty := 1; + + -- Compute the size to allocate given the size of the element and + -- the possible Alignment clause + + Pool.Aligned_Elmt_Size := + SSE.Storage_Count'Max (SC_Size, + ((Pool.Elmt_Size + Align - 1) / Align) * Align); + end if; + end Initialize; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size + (Pool : Stack_Bounded_Pool) + return SSE.Storage_Count + is + begin + return Pool.Pool_Size; + end Storage_Size; + + ------------------------------ + -- Variable_Size_Management -- + ------------------------------ + + package body Variable_Size_Management is + + Minimum_Size : constant := 2 * SC_Size; + + procedure Set_Size + (Pool : Stack_Bounded_Pool; + Chunk, Size : SSE.Storage_Count); + -- Update the field 'size' of a chunk of available storage + + procedure Set_Next + (Pool : Stack_Bounded_Pool; + Chunk, Next : SSE.Storage_Count); + -- Update the field 'next' of a chunk of available storage + + function Size + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) + return SSE.Storage_Count; + -- Fetch the field 'size' of a chunk of available storage + + function Next + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) + return SSE.Storage_Count; + -- Fetch the field 'next' of a chunk of available storage + + function Chunk_Of + (Pool : Stack_Bounded_Pool; + Addr : System.Address) + return SSE.Storage_Count; + -- Give the chunk number in the pool from its Address + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + Chunk : SSE.Storage_Count; + New_Chunk : SSE.Storage_Count; + Prev_Chunk : SSE.Storage_Count; + Our_Align : constant SSE.Storage_Count := + SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, + Alignment); + Align_Size : constant SSE.Storage_Count := + SSE.Storage_Count'Max ( + Minimum_Size, + ((Storage_Size + Our_Align - 1) / Our_Align) * + Our_Align); + + begin + -- Look for the first big enough chunk + + Prev_Chunk := Pool.First_Free; + Chunk := Next (Pool, Prev_Chunk); + + while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop + Prev_Chunk := Chunk; + Chunk := Next (Pool, Chunk); + end loop; + + -- Raise storage_error if no big enough chunk available + + if Chunk = 0 then + raise Storage_Error; + end if; + + -- When the chunk is bigger than what is needed, take appropraite + -- amount and build a new shrinked chunk with the remainder. + + if Size (Pool, Chunk) - Align_Size > Minimum_Size then + New_Chunk := Chunk + Align_Size; + Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size); + Set_Next (Pool, New_Chunk, Next (Pool, Chunk)); + Set_Next (Pool, Prev_Chunk, New_Chunk); + + -- If the chunk is the right size, just delete it from the chain + + else + Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk)); + end if; + + Address := Pool.The_Pool (Chunk)'Address; + end Allocate; + + -------------- + -- Chunk_Of -- + -------------- + + function Chunk_Of + (Pool : Stack_Bounded_Pool; + Addr : System.Address) + return SSE.Storage_Count + is + begin + return 1 + abs (Addr - Pool.The_Pool (1)'Address); + end Chunk_Of; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + Align_Size : constant SSE.Storage_Count := + ((Storage_Size + Alignment - 1) / Alignment) * + Alignment; + Chunk : SSE.Storage_Count := Chunk_Of (Pool, Address); + + begin + -- Attach the freed chunk to the chain + + Set_Size (Pool, Chunk, + SSE.Storage_Count'Max (Align_Size, Minimum_Size)); + Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free)); + Set_Next (Pool, Pool.First_Free, Chunk); + + end Deallocate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Pool : in out Stack_Bounded_Pool) is + begin + Pool.First_Free := 1; + + if Pool.Pool_Size > Minimum_Size then + Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size); + Set_Size (Pool, Pool.First_Free, 0); + Set_Size (Pool, Pool.First_Free + Minimum_Size, + Pool.Pool_Size - Minimum_Size); + Set_Next (Pool, Pool.First_Free + Minimum_Size, 0); + end if; + end Initialize; + + ---------- + -- Next -- + ---------- + + function Next + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) + return SSE.Storage_Count + is + begin + return SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all; + end Next; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next + (Pool : Stack_Bounded_Pool; + Chunk, Next : SSE.Storage_Count) + is + begin + SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next; + end Set_Next; + + -------------- + -- Set_Size -- + -------------- + + procedure Set_Size + (Pool : Stack_Bounded_Pool; + Chunk, Size : SSE.Storage_Count) + is + begin + SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all := Size; + end Set_Size; + + ---------- + -- Size -- + ---------- + + function Size + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) + return SSE.Storage_Count + is + begin + return SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all; + end Size; + + end Variable_Size_Management; +end System.Pool_Size; diff --git a/gcc/ada/s-poosiz.ads b/gcc/ada/s-poosiz.ads new file mode 100644 index 00000000000..ee5de8b9d9f --- /dev/null +++ b/gcc/ada/s-poosiz.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ S I Z E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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.Storage_Pools; +with System.Storage_Elements; + +package System.Pool_Size is + +pragma Elaborate_Body; +-- Needed to ensure that library routines can execute allocators + + ------------------------ + -- Stack_Bounded_Pool -- + ------------------------ + + -- Allocation strategy: + + -- Pool is a regular stack array, no use of malloc + -- user specified size + -- Space of pool is globally reclaimed by normal stack management + + -- Used in the compiler for access types with 'STORAGE_SIZE rep. clause + -- Only used for allocating objects of the same type. + + type Stack_Bounded_Pool + (Pool_Size : System.Storage_Elements.Storage_Count; + Elmt_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is + new System.Storage_Pools.Root_Storage_Pool with record + First_Free : System.Storage_Elements.Storage_Count; + First_Empty : System.Storage_Elements.Storage_Count; + Aligned_Elmt_Size : System.Storage_Elements.Storage_Count; + The_Pool : System.Storage_Elements.Storage_Array + (1 .. Pool_Size); + end record; + + function Storage_Size + (Pool : Stack_Bounded_Pool) + return System.Storage_Elements.Storage_Count; + + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Initialize (Pool : in out Stack_Bounded_Pool); + +end System.Pool_Size; diff --git a/gcc/ada/s-powtab.ads b/gcc/ada/s-powtab.ads new file mode 100644 index 00000000000..6cadc429609 --- /dev/null +++ b/gcc/ada/s-powtab.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O W T E N _ T A B L E -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a powers of ten table used for real conversions + +package System.Powten_Table is +pragma Pure (Powten_Table); + + Maxpow : constant := 22; + -- The number of entries in this table is chosen to include powers of ten + -- that are exactly representable with long_long_float. Assuming that on + -- all targets we have 53 bits of mantissa for the type, the upper bound is + -- given by 53/(log 5). If the scaling factor for a string is greater than + -- Maxpow, it can be obtained by several multiplications, which is less + -- efficient than with a bigger table, but avoids anomalies at end points. + + Powten : constant array (0 .. Maxpow) of Long_Long_Float := + (00 => 1.0E+00, + 01 => 1.0E+01, + 02 => 1.0E+02, + 03 => 1.0E+03, + 04 => 1.0E+04, + 05 => 1.0E+05, + 06 => 1.0E+06, + 07 => 1.0E+07, + 08 => 1.0E+08, + 09 => 1.0E+09, + 10 => 1.0E+10, + 11 => 1.0E+11, + 12 => 1.0E+12, + 13 => 1.0E+13, + 14 => 1.0E+14, + 15 => 1.0E+15, + 16 => 1.0E+16, + 17 => 1.0E+17, + 18 => 1.0E+18, + 19 => 1.0E+19, + 20 => 1.0E+20, + 21 => 1.0E+21, + 22 => 1.0E+22); + +end System.Powten_Table; diff --git a/gcc/ada/s-proinf.adb b/gcc/ada/s-proinf.adb new file mode 100644 index 00000000000..a2f48a3f2cf --- /dev/null +++ b/gcc/ada/s-proinf.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 System.Program_Info is + + Default_Stack_Size : constant := 10000; + + function Default_Task_Stack return Integer is + begin + return Default_Stack_Size; + end Default_Task_Stack; + +end System.Program_Info; diff --git a/gcc/ada/s-proinf.ads b/gcc/ada/s-proinf.ads new file mode 100644 index 00000000000..f54c72246cb --- /dev/null +++ b/gcc/ada/s-proinf.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- Copyright (C) 1996 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 definitions and routines used as parameters +-- to the run-time system at program startup. + +package System.Program_Info is + + function Default_Task_Stack return Integer; + -- + -- The default stack size for each created thread. This default value + -- can be overriden on a per-task basis by the language-defined + -- Storage_Size pragma. + -- + +end System.Program_Info; diff --git a/gcc/ada/s-rpc.adb b/gcc/ada/s-rpc.adb new file mode 100644 index 00000000000..43f1fc0a8db --- /dev/null +++ b/gcc/ada/s-rpc.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R P C -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: this is a dummy implementation which does not support distribution. +-- All the bodies but one therefore raise an exception as defined below. +-- Establish_RPC_Receiver is callable, so that the ACVC scripts can simulate +-- the presence of a master partition to run a test which is otherwise not +-- distributed. + +-- The GLADE distribution package includes a replacement for this file. + +with Ada.Exceptions; use Ada.Exceptions; + +package body System.RPC is + + GNAT : constant Boolean := True; + -- This dummy entity allows the compiler to recognize that this is the + -- version of this package that is supplied by GNAT, not by the user. + -- This is used to cause a compile time error if an attempt is made to + -- use features in System.RPC that are only available from a true PCS. + + CRLF : constant String := ASCII.CR & ASCII.LF; + + Msg : constant String := + CRLF & "Distribution support not installed in your environment" & + CRLF & "For information on GLADE, contact Ada Core Technologies"; + + pragma Warnings (Off); + -- Kill messages about out parameters not set + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Params_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + Raise_Exception (Program_Error'Identity, Msg); + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Params_Stream_Type; + Item : in Ada.Streams.Stream_Element_Array) + is + begin + Raise_Exception (Program_Error'Identity, Msg); + end Write; + + + ------------ + -- Do_RPC -- + ------------ + + procedure Do_RPC + (Partition : in Partition_ID; + Params : access Params_Stream_Type; + Result : access Params_Stream_Type) + is + begin + Raise_Exception (Program_Error'Identity, Msg); + end Do_RPC; + + ------------ + -- Do_APC -- + ------------ + + procedure Do_APC + (Partition : in Partition_ID; + Params : access Params_Stream_Type) + is + begin + Raise_Exception (Program_Error'Identity, Msg); + end Do_APC; + + ---------------------------- + -- Establish_RPC_Receiver -- + ---------------------------- + + procedure Establish_RPC_Receiver + (Partition : in Partition_ID; + Receiver : in RPC_Receiver) + is + begin + null; + end Establish_RPC_Receiver; + +end System.RPC; diff --git a/gcc/ada/s-rpc.ads b/gcc/ada/s-rpc.ads new file mode 100644 index 00000000000..63ab5480a9b --- /dev/null +++ b/gcc/ada/s-rpc.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R P C -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.17 $ -- +-- -- +-- 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: this is a dummy implementation which does not support distribution. +-- The GLADE distribution package includes a replacement for this file which +-- has a different private + +with Ada.Streams; + +package System.RPC is + + type Partition_ID is range 0 .. 63; + -- This type must not be modified without checking the code in + -- a-except.adb, since it expects a Partition_ID whose string + -- representation fits on two characters. + + Communication_Error : exception; + + type Params_Stream_Type + (Initial_Size : Ada.Streams.Stream_Element_Count) is new + Ada.Streams.Root_Stream_Type with private; + + procedure Read + (Stream : in out Params_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Params_Stream_Type; + Item : in Ada.Streams.Stream_Element_Array); + + -- Synchronous call + + procedure Do_RPC + (Partition : in Partition_ID; + Params : access Params_Stream_Type; + Result : access Params_Stream_Type); + + -- Asynchronous call + + procedure Do_APC + (Partition : in Partition_ID; + Params : access Params_Stream_Type); + + -- The handler for incoming RPCs. + + type RPC_Receiver is + access procedure + (Params : access Params_Stream_Type; + Result : access Params_Stream_Type); + + procedure Establish_RPC_Receiver ( + Partition : in Partition_ID; + Receiver : in RPC_Receiver); + +private + + type Params_Stream_Type + (Initial_Size : Ada.Streams.Stream_Element_Count) is new + Ada.Streams.Root_Stream_Type with null record; + +end System.RPC; diff --git a/gcc/ada/s-scaval.ads b/gcc/ada/s-scaval.ads new file mode 100644 index 00000000000..db121d20ba7 --- /dev/null +++ b/gcc/ada/s-scaval.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . S C A L A R _ V A L U E S -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- Copyright (C) 2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 constants used for initializing scalar values +-- when pragma Initialize_Scalars is used. The actual values are defined +-- in the binder generated file. This package contains the Ada names that +-- are used by the generated code, which are linked to the actual values +-- by the use of pragma Import. + +package System.Scalar_Values is +pragma Pure (Scalar_Values); + + type Byte1 is mod 2 ** 8; + type Byte2 is mod 2 ** 16; + type Byte4 is mod 2 ** 32; + type Byte8 is mod 2 ** 64; + + IS_Is1 : constant Byte1; -- Initialize 1 byte signed value + IS_Is2 : constant Byte2; -- Initialize 2 byte signed value + IS_Is4 : constant Byte4; -- Initialize 4 byte signed value + IS_Is8 : constant Byte8; -- Initialize 8 byte signed value + IS_Iu1 : constant Byte1; -- Initialize 1 byte unsigned value + IS_Iu2 : constant Byte2; -- Initialize 2 byte unsigned value + IS_Iu4 : constant Byte4; -- Initialize 4 byte unsigned value + IS_Iu8 : constant Byte8; -- Initialize 8 byte unsigned value + IS_Isf : constant Short_Float; -- Initialize short float value + IS_Ifl : constant Float; -- Initialize float value + IS_Ilf : constant Long_Float; -- Initialize long float value + IS_Ill : constant Long_Long_Float; -- Initialize long long float value + + pragma Import (Ada, IS_Is1, "__gnat_Is1"); + pragma Import (Ada, IS_Is2, "__gnat_Is2"); + pragma Import (Ada, IS_Is4, "__gnat_Is4"); + pragma Import (Ada, IS_Is8, "__gnat_Is8"); + pragma Import (Ada, IS_Iu1, "__gnat_Iu1"); + pragma Import (Ada, IS_Iu2, "__gnat_Iu2"); + pragma Import (Ada, IS_Iu4, "__gnat_Iu4"); + pragma Import (Ada, IS_Iu8, "__gnat_Iu8"); + pragma Import (Ada, IS_Isf, "__gnat_Isf"); + pragma Import (Ada, IS_Ifl, "__gnat_Ifl"); + pragma Import (Ada, IS_Ilf, "__gnat_Ilf"); + pragma Import (Ada, IS_Ill, "__gnat_Ill"); + +end System.Scalar_Values; diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb new file mode 100644 index 00000000000..ac3d9bb9081 --- /dev/null +++ b/gcc/ada/s-secsta.adb @@ -0,0 +1,376 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S E C O N D A R Y _ S T A C K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.49 $ +-- -- +-- 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.Soft_Links; +with System.Parameters; +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Secondary_Stack is + + package SSL renames System.Soft_Links; + + use type SSE.Storage_Offset; + use type System.Parameters.Size_Type; + + SS_Ratio_Dynamic : constant Boolean := + Parameters.Sec_Stack_Ratio = Parameters.Dynamic; + + -- +------------------+ + -- | Next | + -- +------------------+ + -- | | Last (200) + -- | | + -- | | + -- | | + -- | | + -- | | + -- | | First (101) + -- +------------------+ + -- +----------> | | | + -- | +----------+-------+ + -- | | | + -- | ^ V + -- | | | + -- | +-------+----------+ + -- | | | | + -- | +------------------+ + -- | | | Last (100) + -- | | C | + -- | | H | + -- +-----------------+ | +-------->| U | + -- | Current_Chunk -|--+ | | N | + -- +-----------------+ | | K | + -- | Top -|-----+ | | First (1) + -- +-----------------+ +------------------+ + -- | Default_Size | | Prev | + -- +-----------------+ +------------------+ + -- + -- + type Memory is array (Mark_Id range <>) of SSE.Storage_Element; + + type Chunk_Id (First, Last : Mark_Id); + type Chunk_Ptr is access all Chunk_Id; + + type Chunk_Id (First, Last : Mark_Id) is record + Prev, Next : Chunk_Ptr; + Mem : Memory (First .. Last); + end record; + + type Stack_Id is record + Top : Mark_Id; + Default_Size : SSE.Storage_Count; + Current_Chunk : Chunk_Ptr; + end record; + + type Fixed_Stack_Id is record + Top : Mark_Id; + Last : Mark_Id; + Mem : Memory (1 .. Mark_Id'Last / 2 - 1); + -- This should really be 1 .. Mark_Id'Last, but there is a bug in gigi + -- with this type, introduced Sep 2001, that causes gigi to reject this + -- type because its size in bytes overflows ??? + end record; + + type Stack_Ptr is access Stack_Id; + type Fixed_Stack_Ptr is access Fixed_Stack_Id; + + function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr); + function To_Addr is new Unchecked_Conversion (Stack_Ptr, System.Address); + function To_Stack is new Unchecked_Conversion (Fixed_Stack_Ptr, Stack_Ptr); + function To_Fixed is new Unchecked_Conversion (Stack_Ptr, Fixed_Stack_Ptr); + + procedure Free is new Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); + + -------------- + -- Allocate -- + -------------- + + procedure SS_Allocate + (Address : out System.Address; + Storage_Size : SSE.Storage_Count) + is + Stack : constant Stack_Ptr := + From_Addr (SSL.Get_Sec_Stack_Addr.all); + Fixed_Stack : Fixed_Stack_Ptr; + Chunk : Chunk_Ptr; + Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment); + Max_Size : constant Mark_Id := + ((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align) + * Max_Align; + + Count_Unreleased_Chunks : Natural; + To_Be_Released_Chunk : Chunk_Ptr; + + begin + -- If the secondary stack is fixed in the primary stack, then the + -- handling becomes simple + + if not SS_Ratio_Dynamic then + Fixed_Stack := To_Fixed (Stack); + + if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then + raise Storage_Error; + end if; + + Address := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; + Fixed_Stack.Top := Fixed_Stack.Top + Mark_Id (Max_Size); + return; + end if; + + Chunk := Stack.Current_Chunk; + + -- The Current_Chunk may not be the good one if a lot of release + -- operations have taken place. So go down the stack if necessary + + while Chunk.First > Stack.Top loop + Chunk := Chunk.Prev; + end loop; + + -- Find out if the available memory in the current chunk is sufficient. + -- if not, go to the next one and eventally create the necessary room + + Count_Unreleased_Chunks := 0; + + while Chunk.Last - Stack.Top + 1 < Max_Size loop + if Chunk.Next /= null then + + -- Release unused non-first empty chunk + + if Chunk.Prev /= null and then Chunk.First = Stack.Top then + To_Be_Released_Chunk := Chunk; + Chunk := Chunk.Prev; + Chunk.Next := To_Be_Released_Chunk.Next; + To_Be_Released_Chunk.Next.Prev := Chunk; + Free (To_Be_Released_Chunk); + end if; + + -- Create new chunk of the default size unless it is not sufficient + + elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then + Chunk.Next := new Chunk_Id ( + First => Chunk.Last + 1, + Last => Chunk.Last + Mark_Id (Stack.Default_Size)); + + Chunk.Next.Prev := Chunk; + + else + Chunk.Next := new Chunk_Id ( + First => Chunk.Last + 1, + Last => Chunk.Last + Max_Size); + + Chunk.Next.Prev := Chunk; + end if; + + Chunk := Chunk.Next; + Stack.Top := Chunk.First; + end loop; + + -- Resulting address is the address pointed by Stack.Top + + Address := Chunk.Mem (Stack.Top)'Address; + Stack.Top := Stack.Top + Max_Size; + Stack.Current_Chunk := Chunk; + end SS_Allocate; + + ------------- + -- SS_Free -- + ------------- + + procedure SS_Free (Stk : in out System.Address) is + Stack : Stack_Ptr; + Chunk : Chunk_Ptr; + + procedure Free is new Unchecked_Deallocation (Stack_Id, Stack_Ptr); + + begin + if not SS_Ratio_Dynamic then + return; + end if; + + Stack := From_Addr (Stk); + Chunk := Stack.Current_Chunk; + + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + end loop; + + while Chunk.Next /= null loop + Chunk := Chunk.Next; + Free (Chunk.Prev); + end loop; + + Free (Chunk); + Free (Stack); + Stk := Null_Address; + end SS_Free; + + ------------- + -- SS_Info -- + ------------- + + procedure SS_Info is + Stack : constant Stack_Ptr := + From_Addr (SSL.Get_Sec_Stack_Addr.all); + Fixed_Stack : Fixed_Stack_Ptr; + Nb_Chunks : Integer := 1; + Chunk : Chunk_Ptr := Stack.Current_Chunk; + + begin + Put_Line ("Secondary Stack information:"); + + if not SS_Ratio_Dynamic then + Fixed_Stack := To_Fixed (Stack); + Put_Line ( + " Total size : " + & Mark_Id'Image (Fixed_Stack.Last) + & " bytes"); + Put_Line ( + " Current allocated space : " + & Mark_Id'Image (Fixed_Stack.Top - 1) + & " bytes"); + return; + end if; + + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + end loop; + + while Chunk.Next /= null loop + Nb_Chunks := Nb_Chunks + 1; + Chunk := Chunk.Next; + end loop; + + -- Current Chunk information + + Put_Line ( + " Total size : " + & Mark_Id'Image (Chunk.Last) + & " bytes"); + Put_Line ( + " Current allocated space : " + & Mark_Id'Image (Stack.Top - 1) + & " bytes"); + + Put_Line ( + " Number of Chunks : " + & Integer'Image (Nb_Chunks)); + + Put_Line ( + " Default size of Chunks : " + & SSE.Storage_Count'Image (Stack.Default_Size)); + end SS_Info; + + ------------- + -- SS_Init -- + ------------- + + procedure SS_Init + (Stk : in out System.Address; + Size : Natural := Default_Secondary_Stack_Size) + is + Stack : Stack_Ptr; + Fixed_Stack : Fixed_Stack_Ptr; + + begin + if not SS_Ratio_Dynamic then + Fixed_Stack := To_Fixed (From_Addr (Stk)); + Fixed_Stack.Top := Fixed_Stack.Mem'First; + + if Size < 2 * Mark_Id'Max_Size_In_Storage_Elements then + Fixed_Stack.Last := 0; + else + Fixed_Stack.Last := Mark_Id (Size) - + 2 * Mark_Id'Max_Size_In_Storage_Elements; + end if; + + return; + end if; + + Stack := new Stack_Id; + Stack.Current_Chunk := new Chunk_Id (1, Mark_Id (Size)); + Stack.Top := 1; + Stack.Default_Size := SSE.Storage_Count (Size); + + Stk := To_Addr (Stack); + end SS_Init; + + ------------- + -- SS_Mark -- + ------------- + + function SS_Mark return Mark_Id is + begin + return From_Addr (SSL.Get_Sec_Stack_Addr.all).Top; + end SS_Mark; + + ---------------- + -- SS_Release -- + ---------------- + + procedure SS_Release (M : Mark_Id) is + begin + From_Addr (SSL.Get_Sec_Stack_Addr.all).Top := M; + end SS_Release; + + ------------------------- + -- Package Elaboration -- + ------------------------- + + -- Allocate a secondary stack for the main program to use. + -- We make sure that the stack has maximum alignment. Some systems require + -- this (e.g. Sun), and in any case it is a good idea for efficiency. + + Stack : aliased Stack_Id; + for Stack'Alignment use Standard'Maximum_Alignment; + + Chunk : aliased Chunk_Id (1, Default_Secondary_Stack_Size); + for Chunk'Alignment use Standard'Maximum_Alignment; + + Chunk_Address : System.Address; + +begin + if SS_Ratio_Dynamic then + Stack.Top := 1; + Stack.Current_Chunk := Chunk'Access; + Stack.Default_Size := Default_Secondary_Stack_Size; + System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); + + else + Chunk_Address := Chunk'Address; + SS_Init (Chunk_Address, Default_Secondary_Stack_Size); + System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address); + end if; +end System.Secondary_Stack; diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads new file mode 100644 index 00000000000..82d7e6cc50a --- /dev/null +++ b/gcc/ada/s-secsta.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S E C O N D A R Y _ S T A C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- 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 System.Storage_Elements; + +package System.Secondary_Stack is + + package SSE renames System.Storage_Elements; + + Default_Secondary_Stack_Size : constant := 10 * 1024; + -- Default size of a secondary stack + + procedure SS_Init + (Stk : in out System.Address; + Size : Natural := Default_Secondary_Stack_Size); + -- Initialize the secondary stack with a main stack of the given Size. + -- + -- If System.Parameters.Sec_Stack_Ratio equals Dynamic, Stk is really an + -- "out" parameter that will be allocated on the heap. Then all further + -- allocations which do not overflow the main stack will not generate + -- dynamic (de)allocation calls. If the main Stack overflows, a new + -- chuck of at least the same size will be allocated and linked to the + -- previous chunk. + -- + -- Otherwise (Sec_Stack_Ratio between 0 and 100), Stk is an "in" parameter + -- that is already pointing to a Stack_Id. The secondary stack in this case + -- is fixed, and any attempt to allocated more than the initial size will + -- result in a Storage_Error being raised. + -- + -- Note: the reason that Stk is passed is that SS_Init is called before + -- the proper interface is established to obtain the address of the + -- stack using System.Soft_Links.Get_Sec_Stack_Addr. + + procedure SS_Allocate + (Address : out System.Address; + Storage_Size : SSE.Storage_Count); + -- Allocate enough space for a 'Storage_Size' bytes object with Maximum + -- alignment. The address of the allocated space is returned in 'Address' + + procedure SS_Free (Stk : in out System.Address); + -- Release the memory allocated for the Secondary Stack. That is to say, + -- all the allocated chuncks. + -- Upon return, Stk will be set to System.Null_Address + + type Mark_Id is private; + -- Type used to mark the stack. + + function SS_Mark return Mark_Id; + -- Return the Mark corresponding to the current state of the stack + + procedure SS_Release (M : Mark_Id); + -- Restore the state of the stack corresponding to the mark M. If an + -- additional chunk have been allocated, it will never be freed during a + + generic + with procedure Put_Line (S : String); + procedure SS_Info; + -- Debugging procedure used to print out secondary Stack allocation + -- information. This procedure is generic in order to avoid a direct + -- dependance on a particular IO package. + +private + + SS_Pool : Integer; + -- Unused entity that is just present to ease the sharing of the pool + -- mechanism for specific allocation/deallocation in the compiler + + type Mark_Id is new SSE.Integer_Address; + +end System.Secondary_Stack; diff --git a/gcc/ada/s-sequio.adb b/gcc/ada/s-sequio.adb new file mode 100644 index 00000000000..87c6d69ede7 --- /dev/null +++ b/gcc/ada/s-sequio.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . S E Q U E N T I A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- 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 System.File_IO; +with Unchecked_Deallocation; + +package body System.Sequential_IO is + + subtype AP is FCB.AFCB_Ptr; + + package FIO renames System.File_IO; + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Sequential_AFCB) + return FCB.AFCB_Ptr + is + begin + return new Sequential_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + -- No special processing required for Sequential_IO close + + procedure AFCB_Close (File : access Sequential_AFCB) is + begin + null; + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : access Sequential_AFCB) is + + type FCB_Ptr is access all Sequential_AFCB; + + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Unchecked_Deallocation (Sequential_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : in FCB.File_Mode := FCB.Out_File; + Name : in String := ""; + Form : in String := "") + is + File_Control_Block : Sequential_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'Q', + Creat => True, + Text => False); + end Create; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : in FCB.File_Mode; + Name : in String; + Form : in String := "") + is + File_Control_Block : Sequential_AFCB; + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'Q', + Creat => False, + Text => False); + end Open; + + ---------- + -- Read -- + ---------- + + -- Not used, since Sequential_IO files are not used as streams + + procedure Read + (File : in out Sequential_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + raise Program_Error; + end Read; + + ----------- + -- Write -- + ----------- + + -- Not used, since Sequential_IO files are not used as streams + + procedure Write + (File : in out Sequential_AFCB; + Item : in Ada.Streams.Stream_Element_Array) + is + begin + raise Program_Error; + end Write; + +end System.Sequential_IO; diff --git a/gcc/ada/s-sequio.ads b/gcc/ada/s-sequio.ads new file mode 100644 index 00000000000..445729073df --- /dev/null +++ b/gcc/ada/s-sequio.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . S E Q U E N T I A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the declaration of the control block used for +-- Seqential_IO. This must be declared at the outer library level. It also +-- contains code that is shared between instances of Sequential_IO. + +with System.File_Control_Block; +with Ada.Streams; + +package System.Sequential_IO is + + package FCB renames System.File_Control_Block; + + type Sequential_AFCB is new FCB.AFCB with null record; + -- No additional fields required for Sequential_IO + + function AFCB_Allocate + (Control_Block : Sequential_AFCB) + return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : access Sequential_AFCB); + procedure AFCB_Free (File : access Sequential_AFCB); + + procedure Read + (File : in out Sequential_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Required overriding of Read, not actually used for Sequential_IO + + procedure Write + (File : in out Sequential_AFCB; + Item : in Ada.Streams.Stream_Element_Array); + -- Required overriding of Write, not actually used for Sequential_IO + + type File_Type is access all Sequential_AFCB; + -- File_Type in individual instantiations is derived from this type + + procedure Create + (File : in out File_Type; + Mode : in FCB.File_Mode := FCB.Out_File; + Name : in String := ""; + Form : in String := ""); + + procedure Open + (File : in out File_Type; + Mode : in FCB.File_Mode; + Name : in String; + Form : in String := ""); + +end System.Sequential_IO; diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb new file mode 100644 index 00000000000..5d0d45378c0 --- /dev/null +++ b/gcc/ada/s-shasto.adb @@ -0,0 +1,507 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S H A R E D _ M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 Ada.IO_Exceptions; +with Ada.Streams; +with Ada.Streams.Stream_IO; + +with GNAT.HTable; +with System.Global_Locks; +with GNAT.OS_Lib; +with GNAT.Task_Lock; + +use type GNAT.OS_Lib.String_Access; + +with System; +with System.File_Control_Block; +with System.File_IO; +with Unchecked_Deallocation; +with Unchecked_Conversion; + +package body System.Shared_Storage is + + package AS renames Ada.Streams; + + package OS renames GNAT.OS_Lib; + + package IOX renames Ada.IO_Exceptions; + + package FCB renames System.File_Control_Block; + + package SFI renames System.File_IO; + + package TSL renames GNAT.Task_Lock; + + Dir : OS.String_Access; + -- Holds the directory + + ------------------------------------------------ + -- Variables for Shared Variable Access Files -- + ------------------------------------------------ + + Max_Shared_Var_Files : constant := 20; + -- Maximum number of lock files that can be open + + Shared_Var_Files_Open : Natural := 0; + -- Number of shared variable access files currently open + + type File_Stream_Type is new AS.Root_Stream_Type with + record + File : SIO.File_Type; + end record; + type File_Stream_Access is access all File_Stream_Type'Class; + + procedure Read + (Stream : in out File_Stream_Type; + Item : out AS.Stream_Element_Array; + Last : out AS.Stream_Element_Offset); + + procedure Write + (Stream : in out File_Stream_Type; + Item : in AS.Stream_Element_Array); + + subtype Hash_Header is Natural range 0 .. 30; + -- Number of hash headers, related (for efficiency purposes only) + -- to the maximum number of lock files.. + + type Shared_Var_File_Entry; + type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; + + type Shared_Var_File_Entry is record + Name : OS.String_Access; + -- Name of variable, as passed to Read_File/Write_File routines + + Stream : File_Stream_Access; + -- Stream_IO file for the shared variable file + + Next : Shared_Var_File_Entry_Ptr; + Prev : Shared_Var_File_Entry_Ptr; + -- Links for LRU chain + end record; + + procedure Free is new Unchecked_Deallocation + (Object => Shared_Var_File_Entry, + Name => Shared_Var_File_Entry_Ptr); + + procedure Free is new Unchecked_Deallocation + (Object => File_Stream_Type'Class, + Name => File_Stream_Access); + + function To_AFCB_Ptr is + new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); + + LRU_Head : Shared_Var_File_Entry_Ptr; + LRU_Tail : Shared_Var_File_Entry_Ptr; + -- As lock files are opened, they are organized into a least recently + -- used chain, which is a doubly linked list using the Next and Prev + -- fields of Shared_Var_File_Entry records. The field LRU_Head points + -- to the least recently used entry, whose prev pointer is null, and + -- LRU_Tail points to the most recently used entry, whose next pointer + -- is null. These pointers are null only if the list is empty. + + function Hash (F : OS.String_Access) return Hash_Header; + function Equal (F1, F2 : OS.String_Access) return Boolean; + -- Hash and equality functions for hash table + + package SFT is new GNAT.HTable.Simple_HTable + (Header_Num => Hash_Header, + Element => Shared_Var_File_Entry_Ptr, + No_Element => null, + Key => OS.String_Access, + Hash => Hash, + Equal => Equal); + + -------------------------------- + -- Variables for Lock Control -- + -------------------------------- + + Global_Lock : Global_Locks.Lock_Type; + + Lock_Count : Natural := 0; + -- Counts nesting of lock calls, 0 means lock is not held + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Initialize; + -- Called to initialize data structures for this package. + -- Has no effect except on the first call. + + procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String); + -- The first parameter is a pointer to a newly allocated SFE, whose + -- File field is already set appropriately. Fname is the name of the + -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE + -- completes the SFE value, and enters it into the hash table. If the + -- hash table is already full, the least recently used entry is first + -- closed and discarded. + + function Retrieve (File : String) return Shared_Var_File_Entry_Ptr; + -- Given a file name, this function searches the hash table to see if + -- the file is currently open. If so, then a pointer to the already + -- created entry is returned, after first moving it to the head of + -- the LRU chain. If not, then null is returned. + + --------------- + -- Enter_SFE -- + --------------- + + procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is + Freed : Shared_Var_File_Entry_Ptr; + + begin + SFE.Name := new String'(Fname); + + -- Release least recently used entry if we have to + + if Shared_Var_Files_Open = Max_Shared_Var_Files then + Freed := LRU_Head; + + if Freed.Next /= null then + Freed.Next.Prev := null; + end if; + + LRU_Head := Freed.Next; + SFT.Remove (Freed.Name); + SIO.Close (Freed.Stream.File); + OS.Free (Freed.Name); + Free (Freed.Stream); + Free (Freed); + + else + Shared_Var_Files_Open := Shared_Var_Files_Open + 1; + end if; + + -- Add new entry to hash table + + SFT.Set (SFE.Name, SFE); + + -- Add new entry at end of LRU chain + + if LRU_Head = null then + LRU_Head := SFE; + LRU_Tail := SFE; + + else + SFE.Prev := LRU_Tail; + LRU_Tail.Next := SFE; + LRU_Tail := SFE; + end if; + end Enter_SFE; + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : OS.String_Access) return Boolean is + begin + return F1.all = F2.all; + end Equal; + + ---------- + -- Hash -- + ---------- + + function Hash (F : OS.String_Access) return Hash_Header is + N : Natural := 0; + + begin + -- Add up characters of name, mod our table size + + for J in F'Range loop + N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); + end loop; + + return N; + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if Dir = null then + Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY"); + System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock"); + end if; + end Initialize; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out File_Stream_Type; + Item : out AS.Stream_Element_Array; + Last : out AS.Stream_Element_Offset) is + begin + SIO.Read (Stream.File, Item, Last); + exception when others => + Last := Item'Last; + end Read; + + -------------- + -- Retrieve -- + -------------- + + function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is + SFE : Shared_Var_File_Entry_Ptr; + + begin + Initialize; + SFE := SFT.Get (File'Unrestricted_Access); + + if SFE /= null then + + -- Move to head of LRU chain + + if SFE = LRU_Tail then + null; + + elsif SFE = LRU_Head then + LRU_Head := LRU_Head.Next; + LRU_Head.Prev := null; + + else + SFE.Next.Prev := SFE.Prev; + SFE.Prev.Next := SFE.Next; + end if; + + SFE.Next := null; + SFE.Prev := LRU_Tail; + LRU_Tail.Next := SFE; + LRU_Tail := SFE; + end if; + + return SFE; + end Retrieve; + + ---------------------- + -- Shared_Var_Close -- + ---------------------- + + procedure Shared_Var_Close (Var : in SIO.Stream_Access) is + begin + TSL.Unlock; + end Shared_Var_Close; + + --------------------- + -- Shared_Var_Lock -- + --------------------- + + procedure Shared_Var_Lock (Var : in String) is + begin + TSL.Lock; + Initialize; + + if Lock_Count /= 0 then + Lock_Count := Lock_Count + 1; + TSL.Unlock; + + else + Lock_Count := 1; + TSL.Unlock; + System.Global_Locks.Acquire_Lock (Global_Lock); + end if; + + exception + when others => + TSL.Unlock; + raise; + end Shared_Var_Lock; + + ---------------------- + -- Shared_Var_ROpen -- + ---------------------- + + function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is + SFE : Shared_Var_File_Entry_Ptr; + + use type Ada.Streams.Stream_IO.File_Mode; + + begin + TSL.Lock; + SFE := Retrieve (Var); + + -- Here if file is not already open, try to open it + + if SFE = null then + declare + S : aliased constant String := Dir.all & Var; + + begin + SFE := new Shared_Var_File_Entry; + SFE.Stream := new File_Stream_Type; + SIO.Open (SFE.Stream.File, SIO.In_File, Name => S); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + + -- File opened successfully, put new entry in hash table. Note + -- that in this case, file is positioned correctly for read. + + Enter_SFE (SFE, Var); + + exception + -- If we get an exception, it means that the file does not + -- exist, and in this case, we don't need the SFE and we + -- return null; + + when IOX.Name_Error => + Free (SFE); + TSL.Unlock; + return null; + end; + + -- Here if file is already open, set file for reading + + else + if SIO.Mode (SFE.Stream.File) /= SIO.In_File then + SIO.Set_Mode (SFE.Stream.File, SIO.In_File); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + end if; + + SIO.Set_Index (SFE.Stream.File, 1); + end if; + + return SIO.Stream_Access (SFE.Stream); + + exception + when others => + TSL.Unlock; + raise; + end Shared_Var_ROpen; + + ----------------------- + -- Shared_Var_Unlock -- + ----------------------- + + procedure Shared_Var_Unlock (Var : in String) is + begin + TSL.Lock; + Initialize; + Lock_Count := Lock_Count - 1; + + if Lock_Count = 0 then + System.Global_Locks.Release_Lock (Global_Lock); + end if; + TSL.Unlock; + + exception + when others => + TSL.Unlock; + raise; + end Shared_Var_Unlock; + + --------------------- + -- Share_Var_WOpen -- + --------------------- + + function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is + SFE : Shared_Var_File_Entry_Ptr; + + use type Ada.Streams.Stream_IO.File_Mode; + + begin + TSL.Lock; + SFE := Retrieve (Var); + + if SFE = null then + declare + S : aliased constant String := Dir.all & Var; + + begin + SFE := new Shared_Var_File_Entry; + SFE.Stream := new File_Stream_Type; + SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + + exception + -- If we get an exception, it means that the file does not + -- exist, and in this case, we create the file. + + when IOX.Name_Error => + + begin + SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S); + + exception + -- Error if we cannot create the file + + when others => + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, + "Cannot create shared variable file for """ & + S & '"'); -- " + end; + end; + + -- Make new hash table entry for opened/created file. Note that + -- in both cases, the file is already in write mode at the start + -- of the file, ready to be written. + + Enter_SFE (SFE, Var); + + -- Here if file is already open, set file for writing + + else + if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then + SIO.Set_Mode (SFE.Stream.File, SIO.Out_File); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + end if; + + SIO.Set_Index (SFE.Stream.File, 1); + end if; + + return SIO.Stream_Access (SFE.Stream); + + exception + when others => + TSL.Unlock; + raise; + end Shared_Var_WOpen; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out File_Stream_Type; + Item : in AS.Stream_Element_Array) is + begin + SIO.Write (Stream.File, Item); + end Write; + +end System.Shared_Storage; diff --git a/gcc/ada/s-shasto.ads b/gcc/ada/s-shasto.ads new file mode 100644 index 00000000000..d1b5e819edc --- /dev/null +++ b/gcc/ada/s-shasto.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S H A R E D _ S T O R A G E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT 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 manages the shared/persistant storage required for +-- full implementation of variables in Shared_Passive packages, more +-- precisely variables whose enclosing dynamic scope is a shared +-- passive package. This implementation is specific to GNAT and GLADE +-- provides a more general implementation not dedicated to file +-- storage. + +-- -------------------------- +-- -- Shared Storage Model -- +-- -------------------------- + +-- The basic model used is that each partition that references the +-- Shared_Passive package has a local copy of the package data that +-- is initialized in accordance with the declarations of the package +-- in the normal manner. The routines in System.Shared_Storage are +-- then used to ensure that the values in these separate copies are +-- properly synchronized with the state of the overall system. + +-- In the GNAT implementation, this synchronization is ensured by +-- maintaining a set of files, in a designated directory. The +-- directory is designated by setting the environment variable +-- SHARED_MEMORY_DIRECTORY. This variable must be set for all +-- partitions. If the environment variable is not defined, then the +-- current directory is used. + +-- There is one storage for each variable. The name is the fully +-- qualified name of the variable with all letters forced to lower +-- case. For example, the variable Var in the shared passive package +-- Pkg results in the storage name pkg.var. + +-- If the storage does not exist, it indicates that no partition has +-- assigned a new value, so that the initial value is the correct +-- one. This is the critical component of the model. It means that +-- there is no system-wide synchronization required for initializing +-- the package, since the shared storages need not (and do not) +-- reflect the initial state. There is therefore no issue of +-- synchronizing initialization and read/write access. + +-- ----------------------- +-- -- Read/Write Access -- +-- ----------------------- + +-- The approach is as follows: + +-- For each shared variable, var, an access routine varR is created whose +-- body has the following form (this example is for Pkg.Var): + +-- procedure varR is +-- S : Ada.Streams.Stream_IO.Stream_Access; +-- begin +-- S := Shared_Var_ROpen ("pkg.var"); +-- if S /= null then +-- typ'Read (S); +-- Shared_Var_Close (S); +-- end if; +-- end varR; + +-- The routine Shared_Var_ROpen in package System.Shared_Storage +-- either returns null if the storage does not exist, or otherwise a +-- Stream_Access value that references the corresponding shared +-- storage, ready to read the current value. + +-- Each reference to the shared variable, var, is preceded by a +-- call to the corresponding varR procedure, which either leaves the +-- initial value unchanged if the storage does not exist, or reads +-- the current value from the shared storage. + +-- In addition, for each shared variable, var, an assignment routine +-- is created whose body has the following form (again for Pkg.Var) + +-- procedure VarA is +-- S : Ada.Streams.Stream_IO.Stream_Access; +-- begin +-- S := Shared_Var_WOpen ("pkg.var"); +-- typ'Write (S, var); +-- Shared_Var_Close (S); +-- end VarA; + +-- The routine Shared_Var_WOpen in package System.Shared_Storage +-- returns a Stream_Access value that references the corresponding +-- shared storage, ready to write the new value. + +-- Each assignment to the shared variable, var, is followed by a call +-- to the corresponding varA procedure, which writes the new value to +-- the shared storage. + +-- Note that there is no general synchronization for these storage +-- read and write operations, since it is assumed that a correctly +-- operating programs will provide appropriate synchronization. In +-- particular, variables can be protected using protected types with +-- no entries. + +-- The routine Shared_Var_Close is called to indicate the end of a +-- read/write operations. This can be useful even in the context of +-- the GNAT implementation. For instance, when a read operation and a +-- write operation occur at the same time on the same partition, as +-- the same stream is used simultaneously, both operations can +-- terminate abruptly by raising exception Mode_Error because the +-- stream has been opened in read mode and then in write mode and at +-- least used by the read opartion. To avoid this unexpected +-- behaviour, we introduce a synchronization at the partition level. + +-- Note: a special circuit allows the use of stream attributes Read and +-- Write for limited types (using the corresponding attribute for the +-- full type), but there are limitations on the data that can be placed +-- in shared passive partitions. See sem_smem.ads/adb for details. + +-- ---------------------------------------------------------------- +-- -- Handling of Protected Objects in Shared Passive Partitions -- +-- ---------------------------------------------------------------- + +-- In the context of GNAT, during the execution of a protected +-- subprogram call, access is locked out using a locking mechanism +-- per protected object, as provided by the GNAT.Lock_Files +-- capability in the specific case of GNAT. This package contains the +-- lock and unlock calls, and the expander generates a call to the +-- lock routine before the protected call and a call to the unlock +-- routine after the protected call. + +-- Within the code of the protected subprogram, the access to the +-- protected object itself uses the local copy, without any special +-- synchronization. Since global access is locked out, no other task +-- or partition can attempt to read or write this data as long as the +-- lock is held. + +-- The data in the local copy does however need synchronizing with +-- the global values in the shared storage. This is achieved as +-- follows: + +-- The protected object generates a read and assignment routine as +-- described for other shared passive variables. The code for the +-- 'Read and 'Write attributes (not normally allowed, but allowed +-- in this special case) simply reads or writes the values of the +-- components in the protected record. + +-- The lock call is followed by a call to the shared read routine to +-- synchronize the local copy to contain the proper global value. + +-- The unlock call in the procedure case only is preceded by a call +-- to the shared assign routine to synchronize the global shared +-- storages with the (possibly modified) local copy. + +-- These calls to the read and assign routines, as well as the lock +-- and unlock routines, are inserted by the expander (see exp_smem.adb). + +with Ada.Streams.Stream_IO; + +package System.Shared_Storage is + + package SIO renames Ada.Streams.Stream_IO; + + function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns null if the + -- corresponding shared storage does not exist, and otherwise, if + -- the storage does exist, a Stream_Access value that references + -- the shared storage, ready to read the current value. + + function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns a Stream_Access value + -- that references the shared storage, ready to write the new + -- value. The storage is created by this call if it does not + -- already exist. + + procedure Shared_Var_Close (Var : in SIO.Stream_Access); + -- This routine signals the end of a read/assign operation. It can + -- be useful to embrace a read/write operation between a call to + -- open and a call to close which protect the whole operation. + -- Otherwise, two simultaneous operations can result in the + -- raising of exception Data_Error by setting the access mode of + -- the variable in an incorrect mode. + + procedure Shared_Var_Lock (Var : String); + -- This procedure claims the shared storage lock. It is used for + -- protected types in shared passive packages. A call to this + -- locking routine is generated as the first operation in the code + -- for the body of a protected subprogram, and it busy waits if + -- the lock is busy. + + procedure Shared_Var_Unlock (Var : String); + -- This procedure releases the shared storage lock obtaind by a + -- prior call to the Shared_Mem_Lock procedure, and is to be + -- generated as the last operation in the body of a protected + -- subprogram. + +end System.Shared_Storage; diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb new file mode 100644 index 00000000000..518c14ca7f0 --- /dev/null +++ b/gcc/ada/s-soflin.adb @@ -0,0 +1,368 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- an infinite loop from the code within the Poll routine itself. + +with System.Machine_State_Operations; use System.Machine_State_Operations; +-- Used for Create_TSD, Destroy_TSD + +with System.Parameters; +-- Used for Sec_Stack_Ratio + +with System.Secondary_Stack; + +package body System.Soft_Links is + + package SST renames System.Secondary_Stack; + + -- Allocate an exception stack for the main program to use. + -- We make sure that the stack has maximum alignment. Some systems require + -- this (e.g. Sun), and in any case it is a good idea for efficiency. + + NT_Exc_Stack : array (0 .. 8192) of aliased Character; + for NT_Exc_Stack'Alignment use Standard'Maximum_Alignment; + + NT_TSD : TSD; + + -------------------- + -- Abort_Defer_NT -- + -------------------- + + procedure Abort_Defer_NT is + begin + null; + end Abort_Defer_NT; + + ---------------------- + -- Abort_Handler_NT -- + ---------------------- + + procedure Abort_Handler_NT is + begin + null; + end Abort_Handler_NT; + + ---------------------- + -- Abort_Undefer_NT -- + ---------------------- + + procedure Abort_Undefer_NT is + begin + null; + end Abort_Undefer_NT; + + --------------------------- + -- Check_Abort_Status_NT -- + --------------------------- + + function Check_Abort_Status_NT return Integer is + begin + return Boolean'Pos (False); + end Check_Abort_Status_NT; + + ------------------------ + -- Complete_Master_NT -- + ------------------------ + + procedure Complete_Master_NT is + begin + null; + end Complete_Master_NT; + + ---------------- + -- Create_TSD -- + ---------------- + + procedure Create_TSD (New_TSD : in out TSD) is + use type Parameters.Size_Type; + + SS_Ratio_Dynamic : constant Boolean := + Parameters.Sec_Stack_Ratio = Parameters.Dynamic; + begin + + if SS_Ratio_Dynamic then + SST.SS_Init + (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size); + end if; + + New_TSD.Machine_State_Addr := + System.Address + (System.Machine_State_Operations.Allocate_Machine_State); + end Create_TSD; + + ----------------------- + -- Current_Master_NT -- + ----------------------- + + function Current_Master_NT return Integer is + begin + return 0; + end Current_Master_NT; + + ----------------- + -- Destroy_TSD -- + ----------------- + + procedure Destroy_TSD (Old_TSD : in out TSD) is + begin + SST.SS_Free (Old_TSD.Sec_Stack_Addr); + System.Machine_State_Operations.Free_Machine_State + (Machine_State (Old_TSD.Machine_State_Addr)); + end Destroy_TSD; + + --------------------- + -- Enter_Master_NT -- + --------------------- + + procedure Enter_Master_NT is + begin + null; + end Enter_Master_NT; + + -------------------------- + -- Get_Current_Excep_NT -- + -------------------------- + + function Get_Current_Excep_NT return EOA is + begin + return NT_TSD.Current_Excep'Access; + end Get_Current_Excep_NT; + + --------------------------- + -- Get_Exc_Stack_Addr_NT -- + --------------------------- + + function Get_Exc_Stack_Addr_NT return Address is + begin + return NT_TSD.Exc_Stack_Addr; + end Get_Exc_Stack_Addr_NT; + + ----------------------------- + -- Get_Exc_Stack_Addr_Soft -- + ----------------------------- + + function Get_Exc_Stack_Addr_Soft return Address is + begin + return Get_Exc_Stack_Addr.all; + end Get_Exc_Stack_Addr_Soft; + + ------------------------ + -- Get_GNAT_Exception -- + ------------------------ + + function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is + begin + return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all); + end Get_GNAT_Exception; + + --------------------------- + -- Get_Jmpbuf_Address_NT -- + --------------------------- + + function Get_Jmpbuf_Address_NT return Address is + begin + return NT_TSD.Jmpbuf_Address; + end Get_Jmpbuf_Address_NT; + + ----------------------------- + -- Get_Jmpbuf_Address_Soft -- + ----------------------------- + + function Get_Jmpbuf_Address_Soft return Address is + begin + return Get_Jmpbuf_Address.all; + end Get_Jmpbuf_Address_Soft; + + ------------------------------- + -- Get_Machine_State_Addr_NT -- + ------------------------------- + + function Get_Machine_State_Addr_NT return Address is + begin + return NT_TSD.Machine_State_Addr; + end Get_Machine_State_Addr_NT; + + --------------------------------- + -- Get_Machine_State_Addr_Soft -- + --------------------------------- + + function Get_Machine_State_Addr_Soft return Address is + begin + return Get_Machine_State_Addr.all; + end Get_Machine_State_Addr_Soft; + + --------------------------- + -- Get_Sec_Stack_Addr_NT -- + --------------------------- + + function Get_Sec_Stack_Addr_NT return Address is + begin + return NT_TSD.Sec_Stack_Addr; + end Get_Sec_Stack_Addr_NT; + + ----------------------------- + -- Get_Sec_Stack_Addr_Soft -- + ----------------------------- + + function Get_Sec_Stack_Addr_Soft return Address is + begin + return Get_Sec_Stack_Addr.all; + end Get_Sec_Stack_Addr_Soft; + + ----------------------- + -- Get_Stack_Info_NT -- + ----------------------- + + function Get_Stack_Info_NT return Stack_Checking.Stack_Access is + begin + return NT_TSD.Pri_Stack_Info'Access; + end Get_Stack_Info_NT; + + ------------------- + -- Null_Adafinal -- + ------------------- + + procedure Null_Adafinal is + begin + null; + end Null_Adafinal; + + --------------------------- + -- Set_Exc_Stack_Addr_NT -- + --------------------------- + + procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address) is + begin + NT_TSD.Exc_Stack_Addr := Addr; + end Set_Exc_Stack_Addr_NT; + + ----------------------------- + -- Set_Exc_Stack_Addr_Soft -- + ----------------------------- + + procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address) is + begin + Set_Exc_Stack_Addr (Self_ID, Addr); + end Set_Exc_Stack_Addr_Soft; + + --------------------------- + -- Set_Jmpbuf_Address_NT -- + --------------------------- + + procedure Set_Jmpbuf_Address_NT (Addr : Address) is + begin + NT_TSD.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address_NT; + + procedure Set_Jmpbuf_Address_Soft (Addr : Address) is + begin + Set_Jmpbuf_Address (Addr); + end Set_Jmpbuf_Address_Soft; + + ------------------------------- + -- Set_Machine_State_Addr_NT -- + ------------------------------- + + procedure Set_Machine_State_Addr_NT (Addr : Address) is + begin + NT_TSD.Machine_State_Addr := Addr; + end Set_Machine_State_Addr_NT; + + --------------------------------- + -- Set_Machine_State_Addr_Soft -- + --------------------------------- + + procedure Set_Machine_State_Addr_Soft (Addr : Address) is + begin + Set_Machine_State_Addr (Addr); + end Set_Machine_State_Addr_Soft; + + --------------------------- + -- Set_Sec_Stack_Addr_NT -- + --------------------------- + + procedure Set_Sec_Stack_Addr_NT (Addr : Address) is + begin + NT_TSD.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr_NT; + + ----------------------------- + -- Set_Sec_Stack_Addr_Soft -- + ----------------------------- + + procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is + begin + Set_Sec_Stack_Addr (Addr); + end Set_Sec_Stack_Addr_Soft; + + ------------------ + -- Task_Lock_NT -- + ------------------ + + procedure Task_Lock_NT is + begin + null; + end Task_Lock_NT; + + -------------------- + -- Task_Unlock_NT -- + -------------------- + + procedure Task_Unlock_NT is + begin + null; + end Task_Unlock_NT; + + ------------------------- + -- Update_Exception_NT -- + ------------------------- + + procedure Update_Exception_NT (X : EO := Current_Target_Exception) is + begin + Ada.Exceptions.Save_Occurrence (NT_TSD.Current_Excep, X); + end Update_Exception_NT; + + ------------------------- + -- Package Elaboration -- + ------------------------- + +begin + NT_TSD.Exc_Stack_Addr := NT_Exc_Stack (8192)'Address; + Ada.Exceptions.Save_Occurrence + (NT_TSD.Current_Excep, Ada.Exceptions.Null_Occurrence); + +end System.Soft_Links; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads new file mode 100644 index 00000000000..52306076ad1 --- /dev/null +++ b/gcc/ada/s-soflin.ads @@ -0,0 +1,365 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of subprogram access variables that access +-- some low-level primitives that are called different depending wether +-- tasking is involved or not (e.g. the Get/Set_Jmpbuf_Address that needs +-- to provide a different value for each task). To avoid dragging in the +-- tasking all the time, we use a system of soft links where the links are +-- initialized to non-tasking versions, and then if the tasking is +-- initialized, they are reset to the real tasking versions. + +with Ada.Exceptions; +with System.Stack_Checking; + +package System.Soft_Links is + pragma Elaborate_Body; + + subtype EOA is Ada.Exceptions.Exception_Occurrence_Access; + subtype EO is Ada.Exceptions.Exception_Occurrence; + + function Current_Target_Exception return EO; + pragma Import + (Ada, Current_Target_Exception, + "__gnat_current_target_exception"); + -- Import this subprogram from the private part of Ada.Exceptions. + + -- First we have the access subprogram types used to establish the links. + -- The approach is to establish variables containing access subprogram + -- values which by default point to dummy no tasking versions of routines. + + type No_Param_Proc is access procedure; + type Addr_Param_Proc is access procedure (Addr : Address); + + type Get_Address_Call is access function return Address; + type Set_Address_Call is access procedure (Addr : Address); + type Set_Address_Call2 is access procedure + (Self_ID : Address; Addr : Address); + + type Get_Integer_Call is access function return Integer; + type Set_Integer_Call is access procedure (Len : Integer); + + type Get_EOA_Call is access function return EOA; + type Set_EOA_Call is access procedure (Excep : EOA); + type Set_EO_Call is access procedure (Excep : EO); + + type Special_EO_Call is access + procedure (Excep : EO := Current_Target_Exception); + + type Timed_Delay_Call is access + procedure (Time : Duration; Mode : Integer); + + type Get_Stack_Access_Call is access + function return Stack_Checking.Stack_Access; + + -- Suppress checks on all these types, since we know corrresponding + -- values can never be null (the soft links are always initialized). + + pragma Suppress (Access_Check, No_Param_Proc); + pragma Suppress (Access_Check, Addr_Param_Proc); + pragma Suppress (Access_Check, Get_Address_Call); + pragma Suppress (Access_Check, Set_Address_Call); + pragma Suppress (Access_Check, Set_Address_Call2); + pragma Suppress (Access_Check, Get_Integer_Call); + pragma Suppress (Access_Check, Set_Integer_Call); + pragma Suppress (Access_Check, Get_EOA_Call); + pragma Suppress (Access_Check, Set_EOA_Call); + pragma Suppress (Access_Check, Timed_Delay_Call); + pragma Suppress (Access_Check, Get_Stack_Access_Call); + + -- The following one is not related to tasking/no-tasking but to the + -- traceback decorators for exceptions. + + type Traceback_Decorator_Wrapper_Call is access + function (Traceback : System.Address; + Len : Natural) + return String; + + -- Declarations for the no tasking versions of the required routines + + procedure Abort_Defer_NT; + -- Defer task abortion (non-tasking case, does nothing) + + procedure Abort_Undefer_NT; + -- Undefer task abortion (non-tasking case, does nothing) + + procedure Abort_Handler_NT; + -- Handle task abortion (non-tasking case, does nothing). Currently, + -- only VMS uses this. + + procedure Update_Exception_NT + (X : EO := Current_Target_Exception); + -- Handle exception setting. This routine is provided for targets + -- which have built-in exception handling such as the Java Virtual + -- Machine. Currently, only JGNAT uses this. See 4jexcept.ads for + -- an explanation on how this routine is used. + + function Check_Abort_Status_NT return Integer; + -- Returns Boolean'Pos (True) iff abort signal should raise + -- Standard.Abort_Signal. + + procedure Task_Lock_NT; + -- Lock out other tasks (non-tasking case, does nothing) + + procedure Task_Unlock_NT; + -- Release lock set by Task_Lock (non-tasking case, does nothing) + + procedure Null_Adafinal; + -- Shuts down the runtime system (non-tasking no-finalization case, + -- does nothing) + + Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; + pragma Suppress (Access_Check, Abort_Defer); + -- Defer task abortion (task/non-task case as appropriate) + + Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; + pragma Suppress (Access_Check, Abort_Undefer); + -- Undefer task abortion (task/non-task case as appropriate) + + Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; + -- Handle task abortion (task/non-task case as appropriate) + + Update_Exception : Special_EO_Call := Update_Exception_NT'Access; + -- Handle exception setting and tasking polling when appropriate + + Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; + -- Called when Abort_Signal is delivered to the process. Checks to + -- see if signal should result in raising Standard.Abort_Signal. + + Lock_Task : No_Param_Proc := Task_Lock_NT'Access; + -- Locks out other tasks. Preceding a section of code by Task_Lock and + -- following it by Task_Unlock creates a critical region. This is used + -- for ensuring that a region of non-tasking code (such as code used to + -- allocate memory) is tasking safe. Note that it is valid for calls to + -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. + -- only the corresponding outer level Task_Unlock will actually unlock. + -- This routine also prevents against asynchronous aborts (abort is + -- deferred). + + Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access; + -- Releases lock previously set by call to Lock_Task. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + -- + -- In the non nested case, this routine terminates the protection against + -- asynchronous aborts introduced by Lock_Task (unless abort was already + -- deferred before the call to Lock_Task (e.g in a protected procedures). + -- + -- Note: the recommended protocol for using Lock_Task and Unlock_Task + -- is as follows: + -- + -- Locked_Processing : begin + -- System.Soft_Links.Lock_Task.all; + -- ... + -- System.Soft_Links..Unlock_Task.all; + -- + -- exception + -- when others => + -- System.Soft_Links..Unlock_Task.all; + -- raise; + -- end Locked_Processing; + -- + -- This ensures that the lock is not left set if an exception is raised + -- explicitly or implicitly during the critical locked region. + + Adafinal : No_Param_Proc := Null_Adafinal'Access; + -- Performs the finalization of the Ada Runtime. + + function Get_Jmpbuf_Address_NT return Address; + procedure Set_Jmpbuf_Address_NT (Addr : Address); + + Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; + Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; + + function Get_Sec_Stack_Addr_NT return Address; + procedure Set_Sec_Stack_Addr_NT (Addr : Address); + + Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; + Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; + + function Get_Machine_State_Addr_NT return Address; + procedure Set_Machine_State_Addr_NT (Addr : Address); + + Get_Machine_State_Addr : Get_Address_Call + := Get_Machine_State_Addr_NT'Access; + Set_Machine_State_Addr : Set_Address_Call + := Set_Machine_State_Addr_NT'Access; + + function Get_Exc_Stack_Addr_NT return Address; + procedure Set_Exc_Stack_Addr_NT (Self_ID : Address; Addr : Address); + -- Self_ID is a Task_ID, but in the non-tasking case there is no + -- Task_ID type available, so make do with Address. + + Get_Exc_Stack_Addr : Get_Address_Call := Get_Exc_Stack_Addr_NT'Access; + Set_Exc_Stack_Addr : Set_Address_Call2 := Set_Exc_Stack_Addr_NT'Access; + + function Get_Current_Excep_NT return EOA; + + Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; + + function Get_Stack_Info_NT return Stack_Checking.Stack_Access; + + Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access; + + -------------------------- + -- Master_Id Soft-Links -- + -------------------------- + + -- Soft-Links are used for procedures that manipulate Master_Ids because + -- a Master_Id must be generated for access to limited class-wide types, + -- whose root may be extended with task components. + + function Current_Master_NT return Integer; + procedure Enter_Master_NT; + procedure Complete_Master_NT; + + Current_Master : Get_Integer_Call := Current_Master_NT'Access; + Enter_Master : No_Param_Proc := Enter_Master_NT'Access; + Complete_Master : No_Param_Proc := Complete_Master_NT'Access; + + ---------------------- + -- Delay Soft-Links -- + ---------------------- + + -- Soft-Links are used for procedures that manipulate time to avoid + -- dragging the tasking run time when using delay statements. + + Timed_Delay : Timed_Delay_Call; + + ------------------------------------- + -- Exception Tracebacks Soft-Links -- + ------------------------------------- + + Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; + -- Wrapper to the possible user specified traceback decorator to be + -- called during automatic output of exception data. + + -- The nullity of this wrapper shall correspond to the nullity of the + -- current actual decorator. This is ensured first by the null initial + -- value of the corresponding variables, and then by Set_Trace_Decorator + -- in g-exctra.adb. + + pragma Atomic (Traceback_Decorator_Wrapper); + -- Since concurrent read/write operations may occur on this variable. + -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for + -- a more detailed description of the potential problems. + + ------------------------ + -- Task Specific Data -- + ------------------------ + + -- Here we define a single type that encapsulates the various task + -- specific data. This type is used to store the necessary data into + -- the Task_Control_Block or into a global variable in the non tasking + -- case. + + type TSD is record + Pri_Stack_Info : aliased Stack_Checking.Stack_Info; + -- Information on stack (Base/Limit/Size) that is used + -- by System.Stack_Checking. If this TSD does not belong to + -- the environment task, the Size field must be initialized + -- to the tasks requested stack size before the task can do + -- its first stack check. + + Jmpbuf_Address : Address := Null_Address; + -- Address of jump buffer used to store the address of the + -- current longjmp/setjmp buffer for exception management. + -- These buffers are threaded into a stack, and the address + -- here is the top of the stack. A null address means that + -- no exception handler is currently active. + + Sec_Stack_Addr : Address := Null_Address; + -- Address of currently allocated secondary stack + + Exc_Stack_Addr : Address := Null_Address; + -- Address of a task-specific stack used for the propagation of + -- exceptions in response to synchronous faults. This alternate + -- stack is necessary when propagating Storage_Error resulting + -- from a stack overflow, as the task's primary stack is full. + -- This is currently only used on the SGI, and this value stays + -- null on other platforms. + + Current_Excep : aliased EO; + -- Exception occurrence that contains the information for the + -- current exception. Note that any exception in the same task + -- destroys this information, so the data in this variable must + -- be copied out before another exception can occur. + + Machine_State_Addr : Address := Null_Address; + -- + end record; + + procedure Create_TSD (New_TSD : in out TSD); + pragma Inline (Create_TSD); + -- Called from s-tassta when a new thread is created to perform + -- any required initialization of the TSD. + + procedure Destroy_TSD (Old_TSD : in out TSD); + pragma Inline (Destroy_TSD); + -- Called from s-tassta just before a thread is destroyed to perform + -- any required finalization. + + function Get_GNAT_Exception return Ada.Exceptions.Exception_Id; + pragma Inline (Get_GNAT_Exception); + -- This function obtains the Exception_Id from the Exception_Occurrence + -- referenced by the Current_Excep field of the task specific data, i.e. + -- the call is equivalent to + -- Exception_Identity (Get_Current_Exception.all) + + -- Export the Get/Set routines for the various Task Specific Data (TSD) + -- elements as callable subprograms instead of objects of access to + -- subprogram types. + + function Get_Jmpbuf_Address_Soft return Address; + procedure Set_Jmpbuf_Address_Soft (Addr : Address); + pragma Inline (Get_Jmpbuf_Address_Soft); + pragma Inline (Set_Jmpbuf_Address_Soft); + + function Get_Sec_Stack_Addr_Soft return Address; + procedure Set_Sec_Stack_Addr_Soft (Addr : Address); + pragma Inline (Get_Sec_Stack_Addr_Soft); + pragma Inline (Set_Sec_Stack_Addr_Soft); + + function Get_Exc_Stack_Addr_Soft return Address; + procedure Set_Exc_Stack_Addr_Soft (Self_ID : Address; Addr : Address); + pragma Inline (Get_Exc_Stack_Addr_Soft); + pragma Inline (Set_Exc_Stack_Addr_Soft); + + function Get_Machine_State_Addr_Soft return Address; + procedure Set_Machine_State_Addr_Soft (Addr : Address); + pragma Inline (Get_Machine_State_Addr_Soft); + pragma Inline (Set_Machine_State_Addr_Soft); + +end System.Soft_Links; diff --git a/gcc/ada/s-sopco3.adb b/gcc/ada/s-sopco3.adb new file mode 100644 index 00000000000..43da8388bbd --- /dev/null +++ b/gcc/ada/s-sopco3.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 3 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- 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 System.String_Ops_Concat_3 is + + ------------------ + -- Str_Concat_3 -- + ------------------ + + function Str_Concat_3 (S1, S2, S3 : String) return String is + begin + if S1'Length <= 0 then + return S2 & S3; + + else + declare + L12 : constant Natural := S1'Length + S2'Length; + L13 : constant Natural := L12 + S3'Length; + R : String (S1'First .. S1'First + L13 - 1); + + begin + R (S1'First .. S1'Last) := S1; + R (S1'Last + 1 .. S1'First + L12 - 1) := S2; + R (S1'First + L12 .. R'Last) := S3; + return R; + end; + end if; + end Str_Concat_3; + +end System.String_Ops_Concat_3; diff --git a/gcc/ada/s-sopco3.ads b/gcc/ada/s-sopco3.ads new file mode 100644 index 00000000000..a102cbbef89 --- /dev/null +++ b/gcc/ada/s-sopco3.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 3 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- 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 contains the function for concatenating three strings + +package System.String_Ops_Concat_3 is +pragma Pure (String_Ops_Concat_3); + + function Str_Concat_3 (S1, S2, S3 : String) return String; + -- Concatenate two strings and return resulting string + +end System.String_Ops_Concat_3; diff --git a/gcc/ada/s-sopco4.adb b/gcc/ada/s-sopco4.adb new file mode 100644 index 00000000000..136f7e4d9b3 --- /dev/null +++ b/gcc/ada/s-sopco4.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 4 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ -- +-- -- +-- 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 System.String_Ops_Concat_4 is + + ------------------ + -- Str_Concat_4 -- + ------------------ + + function Str_Concat_4 (S1, S2, S3, S4 : String) return String is + begin + if S1'Length <= 0 then + return S2 & S3 & S4; + + else + declare + L12 : constant Natural := S1'Length + S2'Length; + L13 : constant Natural := L12 + S3'Length; + L14 : constant Natural := L13 + S4'Length; + R : String (S1'First .. S1'First + L14 - 1); + + begin + R (S1'First .. S1'Last) := S1; + R (S1'Last + 1 .. S1'First + L12 - 1) := S2; + R (S1'First + L12 .. S1'First + L13 - 1) := S3; + R (S1'First + L13 .. R'Last) := S4; + return R; + end; + end if; + end Str_Concat_4; + +end System.String_Ops_Concat_4; diff --git a/gcc/ada/s-sopco4.ads b/gcc/ada/s-sopco4.ads new file mode 100644 index 00000000000..fdda3e10fb0 --- /dev/null +++ b/gcc/ada/s-sopco4.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 4 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- 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 contains the function for concatenating four strings + +package System.String_Ops_Concat_4 is +pragma Pure (String_Ops_Concat_4); + + function Str_Concat_4 (S1, S2, S3, S4 : String) return String; + -- Concatenate two strings and return resulting string + +end System.String_Ops_Concat_4; diff --git a/gcc/ada/s-sopco5.adb b/gcc/ada/s-sopco5.adb new file mode 100644 index 00000000000..991d6e42381 --- /dev/null +++ b/gcc/ada/s-sopco5.adb @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 5 -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- 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 System.String_Ops_Concat_5 is + + ------------------ + -- Str_Concat_5 -- + ------------------ + + function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String is + begin + if S1'Length <= 0 then + return S2 & S3 & S4 & S5; + + else + declare + L12 : constant Natural := S1'Length + S2'Length; + L13 : constant Natural := L12 + S3'Length; + L14 : constant Natural := L13 + S4'Length; + L15 : constant Natural := L14 + S5'Length; + R : String (S1'First .. S1'First + L15 - 1); + + begin + R (S1'First .. S1'Last) := S1; + R (S1'Last + 1 .. S1'First + L12 - 1) := S2; + R (S1'First + L12 .. S1'First + L13 - 1) := S3; + R (S1'First + L13 .. S1'First + L14 - 1) := S4; + R (S1'First + L14 .. R'Last) := S5; + return R; + end; + end if; + end Str_Concat_5; + +end System.String_Ops_Concat_5; diff --git a/gcc/ada/s-sopco5.ads b/gcc/ada/s-sopco5.ads new file mode 100644 index 00000000000..0da0886b4d3 --- /dev/null +++ b/gcc/ada/s-sopco5.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 5 -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- 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 contains the function for concatenating five strings + +package System.String_Ops_Concat_5 is +pragma Pure (String_Ops_Concat_5); + + function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String; + -- Concatenate two strings and return resulting string + +end System.String_Ops_Concat_5; diff --git a/gcc/ada/s-stache.adb b/gcc/ada/s-stache.adb new file mode 100644 index 00000000000..3a5e5b3176a --- /dev/null +++ b/gcc/ada/s-stache.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- Copyright (C) 1999-2001 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 Ada.Exceptions; + +with System.Storage_Elements; use System.Storage_Elements; +with System.Parameters; use System.Parameters; +with System.Soft_Links; + +package body System.Stack_Checking is + + Kilobyte : constant Storage_Offset := 1024; + Default_Env_Stack_Size : constant Storage_Offset := 8000 * Kilobyte; + -- This size is assumed for the environment stack when no size has been + -- set by the runtime, and no GNAT_STACK_LIMIT environment variable was + -- present. The value is chosen to be just under 8 MB whic is the actual + -- default size on some systems including LinuxThreads, so we will get + -- correct storage errors on those systems without setting environment + -- variables. + + function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access; + + -- The function Set_Stack_Info is the actual function that updates + -- the cache containing a pointer to the Stack_Info. It may also + -- be used for detecting asynchronous abort in combination with + -- Invalidate_Self_Cache. + + -- Set_Stack_Info should do the following things in order: + -- 1) Get the Stack_Access value for the current task + -- 2) Set Stack.all to the value obtained in 1) + -- 3) Optionally Poll to check for asynchronous abort + + -- This order is important because if at any time a write to + -- the stack cache is pending, that write should be followed + -- by a Poll to prevent loosing signals. + + -- Note: This function must be compiled with Polling turned off + + -- Note: on systems like VxWorks and OS/2 with real thread-local storage, + -- Set_Stack_Info should return an access value for such local + -- storage. In those cases the cache will always be up-to-date. + + -- The following constants should be imported from some system-specific + -- constants package. The constants must be static for performance reasons. + + ---------------------------- + -- Invalidate_Stack_Cache -- + ---------------------------- + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + begin + Cache := Null_Stack; + end Invalidate_Stack_Cache; + + -------------------- + -- Set_Stack_Info -- + -------------------- + + function Set_Stack_Info + (Stack : access Stack_Access) + return Stack_Access + is + type Frame_Mark is null record; + Frame_Location : Frame_Mark; + Frame_Address : Address := Frame_Location'Address; + + My_Stack : Stack_Access; + Limit_Chars : System.Address; + Limit : Integer; + + function getenv (S : String) return System.Address; + pragma Import (C, getenv, External_Name => "getenv"); + + function atoi (A : System.Address) return Integer; + pragma Import (C, atoi); + + begin + -- The order of steps 1 .. 3 is important, see specification. + + -- 1) Get the Stack_Access value for the current task + + My_Stack := Soft_Links.Get_Stack_Info.all; + + if My_Stack.Base = Null_Address then + + -- First invocation, initialize based on the assumption that + -- there are Environment_Stack_Size bytes available beyond + -- the current frame address. + + if My_Stack.Size = 0 then + + My_Stack.Size := Default_Env_Stack_Size; + + -- When the environment variable GNAT_STACK_LIMIT is set, + -- set Environment_Stack_Size to that number of kB. + + Limit_Chars := getenv ("GNAT_STACK_LIMIT" & ASCII.NUL); + + if Limit_Chars /= Null_Address then + Limit := atoi (Limit_Chars); + if Limit >= 0 then + My_Stack.Size := Storage_Offset (Limit) * Kilobyte; + end if; + end if; + end if; + + My_Stack.Base := Frame_Address; + + if Stack_Grows_Down then + + -- Prevent wrap-around on too big stack sizes + + My_Stack.Limit := My_Stack.Base - My_Stack.Size; + + if My_Stack.Limit > My_Stack.Base then + My_Stack.Limit := Address'First; + end if; + + else + My_Stack.Limit := My_Stack.Base + My_Stack.Size; + + -- Prevent wrap-around on too big stack sizes + + if My_Stack.Limit < My_Stack.Base then + My_Stack.Limit := Address'Last; + end if; + end if; + end if; + + -- 2) Set Stack.all to the value obtained in 1) + + Stack.all := My_Stack; + + -- 3) Optionally Poll to check for asynchronous abort + + if Soft_Links.Check_Abort_Status.all /= 0 then + raise Standard'Abort_Signal; + end if; + + return My_Stack; -- Never trust the cached value, but return local copy! + end Set_Stack_Info; + + -------------------- + -- Set_Stack_Size -- + -------------------- + + -- Specify the stack size for the current frame. + + procedure Set_Stack_Size + (Stack_Size : System.Storage_Elements.Storage_Offset) + is + My_Stack : Stack_Access; + Frame_Address : constant System.Address := My_Stack'Address; + + begin + My_Stack := Stack_Check (Frame_Address); + + if Stack_Grows_Down then + My_Stack.Limit := My_Stack.Base - Stack_Size; + else + My_Stack.Limit := My_Stack.Base + Stack_Size; + end if; + end Set_Stack_Size; + + ----------------- + -- Stack_Check -- + ----------------- + + function Stack_Check + (Stack_Address : System.Address) + return Stack_Access + is + type Frame_Marker is null record; + Marker : Frame_Marker; + Cached_Stack : constant Stack_Access := Cache; + Frame_Address : constant System.Address := Marker'Address; + + begin + -- This function first does a "cheap" check which is correct + -- if it succeeds. In case of failure, the full check is done. + -- Ideally the cheap check should be done in an optimized manner, + -- or be inlined. + + if (Stack_Grows_Down and then + (Frame_Address <= Cached_Stack.Base + and + Stack_Address > Cached_Stack.Limit)) + or else + (not Stack_Grows_Down and then + (Frame_Address >= Cached_Stack.Base + and + Stack_Address < Cached_Stack.Limit)) + then + -- Cached_Stack is valid as it passed the stack check + return Cached_Stack; + end if; + + Full_Check : + declare + My_Stack : Stack_Access := Set_Stack_Info (Cache'Access); + -- At this point Stack.all might already be invalid, so + -- it is essential to use our local copy of Stack! + + begin + + if (Stack_Grows_Down and then + (not (Frame_Address <= My_Stack.Base))) + or else + (not Stack_Grows_Down and then + (not (Frame_Address >= My_Stack.Base))) + then + -- The returned Base is lower than the stored one, + -- so assume that the original one wasn't right and use the + -- current Frame_Address as new one. This allows initializing + -- Base with the Frame_Address as approximation. + -- During initialization the Frame_Address will be close to + -- the stack base anyway: the difference should be compensated + -- for in the stack reserve. + + My_Stack.Base := Frame_Address; + end if; + + if (Stack_Grows_Down and then + Stack_Address < My_Stack.Limit) + or else + (not Stack_Grows_Down and then + Stack_Address > My_Stack.Limit) + then + Ada.Exceptions.Raise_Exception + (E => Storage_Error'Identity, + Message => "stack overflow detected"); + end if; + + return My_Stack; + end Full_Check; + end Stack_Check; + + ------------------------ + -- Update_Stack_Cache -- + ------------------------ + + procedure Update_Stack_Cache (Stack : Stack_Access) is + begin + if not Multi_Processor then + Cache := Stack; + end if; + end Update_Stack_Cache; + +end System.Stack_Checking; diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads new file mode 100644 index 00000000000..d95c7021a54 --- /dev/null +++ b/gcc/ada/s-stache.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1999-2001 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 provides a system-independent implementation of stack +-- checking using comparison with stack base and limit. + +with System.Storage_Elements; + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during stack +-- checking operations. It causes infinite loops and other problems. + +package System.Stack_Checking is + type Stack_Info is record + Limit : System.Address := System.Null_Address; + Base : System.Address := System.Null_Address; + Size : System.Storage_Elements.Storage_Offset := 0; + end record; + -- This record may be part of a larger data structure like the + -- task control block in the tasking case. + -- This specific layout has the advantage of being compatible with the + -- Intel x86 BOUNDS instruction. + + type Stack_Access is access all Stack_Info; + -- Unique local storage associated with a specific task. This storage is + -- used for the stack base and limit, and is returned by Checked_Self. + -- Only self may write this information, it may be read by any task. + -- At no time the address range Limit .. Base (or Base .. Limit for + -- upgrowing stack) may contain any address that is part of another stack. + -- The Stack_Access may be part of a larger data structure. + + Multi_Processor : constant Boolean := False; -- Not supported yet + + ---------------------- + -- Client Interface -- + ---------------------- + + procedure Set_Stack_Size + (Stack_Size : System.Storage_Elements.Storage_Offset); + -- Specify the stack size for the current task. + + procedure Update_Stack_Cache (Stack : Stack_Access); + -- Set the stack cache for the current task. Note that this is only + -- for optimization purposes, nothing can be assumed about the + -- contents of the cache at any time, see Set_Stack_Info. + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access); + -- Invalidate cache entries for the task T that owns Any_Stack. + -- This causes the Set_Stack_Info function to be called during + -- the next stack check done by T. This can be used to interrupt + -- task T asynchronously. + -- Stack_Check should be called in loops for this to work reliably. + + function Stack_Check (Stack_Address : System.Address) return Stack_Access; + -- This version of Stack_Check should not be inlined. + +private + + Null_Stack_Info : aliased Stack_Info := + (Limit => System.Null_Address, + Base => System.Null_Address, + Size => 0); + -- Use explicit assignment to avoid elaboration code (call to _init_proc). + + Null_Stack : constant Stack_Access := Null_Stack_Info'Access; + -- Stack_Access value that will return a Stack_Base and Stack_Limit + -- that fail any stack check. + + Cache : aliased Stack_Access := Null_Stack; + + pragma Export (C, Cache, "_gnat_stack_cache"); + pragma Export (C, Stack_Check, "_gnat_stack_check"); + +end System.Stack_Checking; diff --git a/gcc/ada/s-stalib.adb b/gcc/ada/s-stalib.adb new file mode 100644 index 00000000000..71fb5ccffc3 --- /dev/null +++ b/gcc/ada/s-stalib.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T A N D A R D _ L I B R A R Y -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.17 $ +-- -- +-- Copyright (C) 1995-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). -- +-- -- +------------------------------------------------------------------------------ + +-- The purpose of this body is simply to ensure that the two with'ed units +-- are properly included in the link. They are not with'ed from the spec +-- of System.Standard_Library, since this would cause order of elaboration +-- problems (Elaborate_Body would have the same problem). + +pragma Warnings (Off); +-- Kill warnings from unused withs + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions if polling is on. + +with System.Soft_Links; +-- Referenced directly from generated code +-- Also referenced from exception handling routines. +-- This is needed for programs that don't use exceptions explicitely but +-- direct calls to Ada.Exceptions are generated by gigi (for example, +-- by calling __gnat_raise_constraint_error directly). + +with System.Memory; +-- Referenced directly from generated code + +package body System.Standard_Library is + + Runtime_Finalized : Boolean := False; + -- Set to True when adafinal is called. Used to ensure that subsequent + -- calls to adafinal after the first have no effect. + + Inside_Elab_Final_Code : Integer := 0; + pragma Export (C, Inside_Elab_Final_Code, "__gnat_inside_elab_final_code"); + -- ???This variable is obsolete starting from 29/08 but cannot be removed + -- ???right away due to the bootstrap problems + + -------------------------- + -- Abort_Undefer_Direct -- + -------------------------- + + procedure Abort_Undefer_Direct is + begin + System.Soft_Links.Abort_Undefer.all; + end Abort_Undefer_Direct; + + -------------- + -- Adafinal -- + -------------- + + procedure Adafinal is + begin + if not Runtime_Finalized then + Runtime_Finalized := True; + System.Soft_Links.Adafinal.all; + end if; + end Adafinal; + +end System.Standard_Library; diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads new file mode 100644 index 00000000000..cfd6622158f --- /dev/null +++ b/gcc/ada/s-stalib.ads @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T A N D A R D _ L I B R A R Y -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.43 $ +-- -- +-- 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 is included in all programs. It contains declarations that +-- are required to be part of every Ada program. A special mechanism is +-- required to ensure that these are loaded, since it may be the case in +-- some programs that the only references to these required packages are +-- from C code or from code generated directly by Gigi, an in both cases +-- the binder is not aware of such references. + +-- System.Standard_Library also includes data that must be present in every +-- program, in particular the definitions of all the standard and also some +-- subprograms that must be present in every program. + +-- The binder unconditionally includes s-stalib.ali, which ensures that this +-- package and the packages it references are included in all Ada programs, +-- together with the included data. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions if polling is on. + +with System; +with Unchecked_Conversion; + +package System.Standard_Library is + + pragma Suppress (All_Checks); + -- Suppress explicitely all the checks to work around the Solaris linker + -- bug when using gnatmake -f -a (but without -gnatp). This is not needed + -- with Solaris 2.6, so eventually can be removed ??? + + type Big_String_Ptr is access all String (Positive); + -- A non-fat pointer type for null terminated strings + + function To_Ptr is + new Unchecked_Conversion (System.Address, Big_String_Ptr); + + --------------------------------------------- + -- Type For Enumeration Image Index Tables -- + --------------------------------------------- + + -- Note: these types are declared at the start of this unit, since + -- they must appear before any enumeration types declared in this + -- unit. Note that the spec of system is already elaborated at + -- this point (since we are a child of system), which means that + -- enumeration types in package System cannot use these types. + + type Image_Index_Table_8 is + array (Integer range <>) of Short_Short_Integer; + type Image_Index_Table_16 is + array (Integer range <>) of Short_Integer; + type Image_Index_Table_32 is + array (Integer range <>) of Integer; + -- These types are used to generate the index vector used for enumeration + -- type image tables. See spec of Exp_Imgv in the main GNAT sources for a + -- full description of the data structures that are used here. + + ------------------------------------- + -- Exception Declarations and Data -- + ------------------------------------- + + type Exception_Data; + type Exception_Data_Ptr is access all Exception_Data; + -- An equivalent of Exception_Id that is public + + -- The following record defines the underlying representation of exceptions + + -- WARNING! Any changes to this may need to be reflectd in the following + -- locations in the compiler and runtime code: + + -- 1. The Internal_Exception routine in s-exctab.adb + -- 2. The processing in gigi that tests Not_Handled_By_Others + -- 3. Expand_N_Exception_Declaration in Exp_Ch11 + -- 4. The construction of the exception type in Cstand + + type Exception_Data is record + Not_Handled_By_Others : Boolean; + -- Normally set False, indicating that the exception is handled in the + -- usual way by others (i.e. an others handler handles the exception). + -- Set True to indicate that this exception is not caught by others + -- handlers, but must be explicitly named in a handler. This latter + -- setting is currently used by the Abort_Signal. + + Lang : Character; + -- A character indicating the language raising the exception. + -- Set to "A" for exceptions defined by an Ada program. + -- Set to "V" for imported VMS exceptions. + + Name_Length : Natural; + -- Length of fully expanded name of exception + + Full_Name : Big_String_Ptr; + -- Fully expanded name of exception, null terminated + + HTable_Ptr : Exception_Data_Ptr; + -- Hash table pointer used to link entries together in the hash table + -- built (by Register_Exception in s-exctab.adb) for converting between + -- identities and names. + + Import_Code : Integer; + -- Value for imported exceptions. Needed only for the handling of + -- Import/Export_Exception for the VMS case, but present in all + -- implementations (we might well extend this mechanism for other + -- systems in the future). + + end record; + + -- Definitions for standard predefined exceptions defined in Standard, + + -- Why are the Nul's necessary here, seems like they should not be + -- required, since Gigi is supposed to add a Nul to each name ??? + + Constraint_Error_Name : constant String := "CONSTRAINT_ERROR" & ASCII.NUL; + Program_Error_Name : constant String := "PROGRAM_ERROR" & ASCII.NUL; + Storage_Error_Name : constant String := "STORAGE_ERROR" & ASCII.NUL; + Tasking_Error_Name : constant String := "TASKING_ERROR" & ASCII.NUL; + Abort_Signal_Name : constant String := "_ABORT_SIGNAL" & ASCII.NUL; + + Numeric_Error_Name : constant String := "NUMERIC_ERROR" & ASCII.NUL; + -- This is used only in the Ada 83 case, but it is not worth having a + -- separate version of s-stalib.ads for use in Ada 83 mode. + + Constraint_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Constraint_Error_Name'Length, + Full_Name => To_Ptr (Constraint_Error_Name'Address), + HTable_Ptr => null, + Import_Code => 0); + + Numeric_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Numeric_Error_Name'Length, + Full_Name => To_Ptr (Numeric_Error_Name'Address), + HTable_Ptr => null, + Import_Code => 0); + + Program_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Program_Error_Name'Length, + Full_Name => To_Ptr (Program_Error_Name'Address), + HTable_Ptr => null, + Import_Code => 0); + + Storage_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Storage_Error_Name'Length, + Full_Name => To_Ptr (Storage_Error_Name'Address), + HTable_Ptr => null, + Import_Code => 0); + + Tasking_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Tasking_Error_Name'Length, + Full_Name => To_Ptr (Tasking_Error_Name'Address), + HTable_Ptr => null, + Import_Code => 0); + + Abort_Signal_Def : aliased Exception_Data := + (Not_Handled_By_Others => True, + Lang => 'A', + Name_Length => Abort_Signal_Name'Length, + Full_Name => To_Ptr (Abort_Signal_Name'Address), + HTable_Ptr => null, + Import_Code => 0); + + pragma Export (C, Constraint_Error_Def, "constraint_error"); + pragma Export (C, Numeric_Error_Def, "numeric_error"); + pragma Export (C, Program_Error_Def, "program_error"); + pragma Export (C, Storage_Error_Def, "storage_error"); + pragma Export (C, Tasking_Error_Def, "tasking_error"); + pragma Export (C, Abort_Signal_Def, "_abort_signal"); + + Local_Partition_ID : Natural := 0; + -- This variable contains the local Partition_ID that will be used when + -- building exception occurrences. In distributed mode, it will be + -- set by each partition to the correct value during the elaboration. + + type Exception_Trace_Kind is + (RM_Convention, + -- No particular trace is requested, only unhandled exceptions + -- in the environment task (following the RM) will be printed. + -- This is the default behavior. + + Every_Raise, + -- Denotes every possible raise event, either explicit or due to + -- a specific language rule, within the context of a task or not. + + Unhandled_Raise + -- Denotes the raise events corresponding to exceptions for which + -- there is no user defined handler. + ); + -- Provide a way to denote different kinds of automatic traces related + -- to exceptions that can be requested. + + Exception_Trace : Exception_Trace_Kind := RM_Convention; + pragma Atomic (Exception_Trace); + -- By default, follow the RM convention. + + ----------------- + -- Subprograms -- + ----------------- + + procedure Abort_Undefer_Direct; + pragma Inline (Abort_Undefer_Direct); + -- A little procedure that just calls Abort_Undefer.all, for use in + -- clean up procedures, which only permit a simple subprogram name. + + procedure Adafinal; + -- Performs the Ada Runtime finalization the first time it is invoked. + -- All subsequent calls are ignored. + +end System.Standard_Library; diff --git a/gcc/ada/s-stoele.adb b/gcc/ada/s-stoele.adb new file mode 100644 index 00000000000..b469ad208b7 --- /dev/null +++ b/gcc/ada/s-stoele.adb @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ E L E M E N T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- 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 Unchecked_Conversion; +package body System.Storage_Elements is + + pragma Suppress (All_Checks); + + function To_Address is new Unchecked_Conversion (Storage_Offset, Address); + function To_Offset is new Unchecked_Conversion (Address, Storage_Offset); + + -- Address arithmetic + + function "+" (Left : Address; Right : Storage_Offset) return Address is + begin + return Left + To_Address (Right); + end "+"; + + function "+" (Left : Storage_Offset; Right : Address) return Address is + begin + return To_Address (Left) + Right; + end "+"; + + function "-" (Left : Address; Right : Storage_Offset) return Address is + begin + return Left - To_Address (Right); + end "-"; + + function "-" (Left, Right : Address) return Storage_Offset is + begin + return To_Offset (Left - Right); + end "-"; + + function "mod" (Left : Address; Right : Storage_Offset) + return Storage_Offset is + begin + if Right >= 0 then + return Storage_Offset (Address'(Left mod Address (Right))); + else + return -Storage_Offset (Address'(Left mod Address (-Right))); + end if; + end "mod"; + + -- Conversion to/from integers + + function To_Address (Value : Integer_Address) return Address is + begin + return Address (Value); + end To_Address; + + function To_Integer (Value : Address) return Integer_Address is + begin + return Integer_Address (Value); + end To_Integer; + +end System.Storage_Elements; diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads new file mode 100644 index 00000000000..18a170b0b2d --- /dev/null +++ b/gcc/ada/s-stoele.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ E L E M E N T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.23 $ -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Warning: declarations in this package are ambiguous with respect to the +-- extra declarations that can be introduced into System using Extend_System. +-- It is a good idea to avoid use clauses for this package! + +pragma Warnings (Off); +-- This is to stop bootstrap problems with the use of Inline_Always +-- To be removed (along with redundant Inline pragmas) in 3.13. + +package System.Storage_Elements is +pragma Pure (Storage_Elements); +-- Note that we take advantage of the implementation permission to make +-- this unit Pure instead of Preelaborable; see RM 13.7.1(15). + + type Storage_Offset is range + -(2 ** (Standard."-" (Standard'Address_Size, 1))) .. + +(2 ** (Standard."-" (Standard'Address_Size, 1))) - 1; + -- Note: the reason for the qualification of "-" here by Standard is + -- that we have a current bug in GNAT that otherwise causes a bogus + -- ambiguity when this unit is analyzed in an Rtsfind context. + + subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last; + + type Storage_Element is mod 2 ** Storage_Unit; + for Storage_Element'Size use Storage_Unit; + + type Storage_Array is + array (Storage_Offset range <>) of aliased Storage_Element; + for Storage_Array'Component_Size use Storage_Unit; + + -- Address arithmetic + + function "+" (Left : Address; Right : Storage_Offset) return Address; + pragma Convention (Intrinsic, "+"); + pragma Inline ("+"); + pragma Inline_Always ("+"); + + function "+" (Left : Storage_Offset; Right : Address) return Address; + pragma Convention (Intrinsic, "+"); + pragma Inline ("+"); + pragma Inline_Always ("+"); + + function "-" (Left : Address; Right : Storage_Offset) return Address; + pragma Convention (Intrinsic, "-"); + pragma Inline ("-"); + pragma Inline_Always ("-"); + + function "-" (Left, Right : Address) return Storage_Offset; + pragma Convention (Intrinsic, "-"); + pragma Inline ("-"); + pragma Inline_Always ("-"); + + function "mod" + (Left : Address; + Right : Storage_Offset) + return Storage_Offset; + pragma Convention (Intrinsic, "mod"); + pragma Inline ("mod"); + pragma Inline_Always ("mod"); + + -- Conversion to/from integers + + type Integer_Address is mod Memory_Size; + + function To_Address (Value : Integer_Address) return Address; + pragma Convention (Intrinsic, To_Address); + pragma Inline (To_Address); + pragma Inline_Always (To_Address); + + function To_Integer (Value : Address) return Integer_Address; + pragma Convention (Intrinsic, To_Integer); + pragma Inline (To_Integer); + pragma Inline_Always (To_Integer); + +end System.Storage_Elements; diff --git a/gcc/ada/s-stopoo.ads b/gcc/ada/s-stopoo.ads new file mode 100644 index 00000000000..b6982e357f5 --- /dev/null +++ b/gcc/ada/s-stopoo.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ P O O L S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.15 $ -- +-- -- +-- 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.Finalization; +with System.Storage_Elements; + +package System.Storage_Pools is + pragma Preelaborate (System.Storage_Pools); + + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with private; + + procedure Allocate + (Pool : in out Root_Storage_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; + Alignment : in System.Storage_Elements.Storage_Count) + is abstract; + + procedure Deallocate + (Pool : in out Root_Storage_Pool; + Storage_Address : in Address; + Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count; + Alignment : in System.Storage_Elements.Storage_Count) + is abstract; + + function Storage_Size + (Pool : Root_Storage_Pool) + return System.Storage_Elements.Storage_Count + is abstract; + +private + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with null record; +end System.Storage_Pools; diff --git a/gcc/ada/s-stratt.adb b/gcc/ada/s-stratt.adb new file mode 100644 index 00000000000..83964752bb7 --- /dev/null +++ b/gcc/ada/s-stratt.adb @@ -0,0 +1,674 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- 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.IO_Exceptions; +with Ada.Streams; use Ada.Streams; +with Unchecked_Conversion; + +package body System.Stream_Attributes is + + Err : exception renames Ada.IO_Exceptions.End_Error; + -- Exception raised if insufficient data read (note that the RM implies + -- that Data_Error might be the appropriate choice, but AI195-00132 + -- decides with a binding interpretation that End_Error is preferred). + + SU : constant := System.Storage_Unit; + + subtype SEA is Ada.Streams.Stream_Element_Array; + subtype SEO is Ada.Streams.Stream_Element_Offset; + + generic function UC renames Unchecked_Conversion; + + -- Subtypes used to define Stream_Element_Array values that map + -- into the elementary types, using unchecked conversion. + + Thin_Pointer_Size : constant := System.Address'Size; + Fat_Pointer_Size : constant := System.Address'Size * 2; + + subtype S_AD is SEA (1 .. (Fat_Pointer_Size + SU - 1) / SU); + subtype S_AS is SEA (1 .. (Thin_Pointer_Size + SU - 1) / SU); + subtype S_B is SEA (1 .. (Boolean'Size + SU - 1) / SU); + subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU); + subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU); + subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU); + subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU); + subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU); + subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU); + subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size + SU - 1) / SU); + subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size + SU - 1) / SU); + subtype S_LU is SEA (1 .. (UST.Long_Unsigned'Size + SU - 1) / SU); + subtype S_SF is SEA (1 .. (Short_Float'Size + SU - 1) / SU); + subtype S_SI is SEA (1 .. (Short_Integer'Size + SU - 1) / SU); + subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size + SU - 1) / SU); + subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU); + subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU); + subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU); + subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU); + + -- Unchecked conversions from the elementary type to the stream type + + function From_AD is new UC (Fat_Pointer, S_AD); + function From_AS is new UC (Thin_Pointer, S_AS); + function From_C is new UC (Character, S_C); + function From_F is new UC (Float, S_F); + function From_I is new UC (Integer, S_I); + function From_LF is new UC (Long_Float, S_LF); + function From_LI is new UC (Long_Integer, S_LI); + function From_LLF is new UC (Long_Long_Float, S_LLF); + function From_LLI is new UC (Long_Long_Integer, S_LLI); + function From_LLU is new UC (UST.Long_Long_Unsigned, S_LLU); + function From_LU is new UC (UST.Long_Unsigned, S_LU); + function From_SF is new UC (Short_Float, S_SF); + function From_SI is new UC (Short_Integer, S_SI); + function From_SSI is new UC (Short_Short_Integer, S_SSI); + function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU); + function From_SU is new UC (UST.Short_Unsigned, S_SU); + function From_U is new UC (UST.Unsigned, S_U); + function From_WC is new UC (Wide_Character, S_WC); + + -- Unchecked conversions from the stream type to elementary type + + function To_AD is new UC (S_AD, Fat_Pointer); + function To_AS is new UC (S_AS, Thin_Pointer); + function To_C is new UC (S_C, Character); + function To_F is new UC (S_F, Float); + function To_I is new UC (S_I, Integer); + function To_LF is new UC (S_LF, Long_Float); + function To_LI is new UC (S_LI, Long_Integer); + function To_LLF is new UC (S_LLF, Long_Long_Float); + function To_LLI is new UC (S_LLI, Long_Long_Integer); + function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned); + function To_LU is new UC (S_LU, UST.Long_Unsigned); + function To_SF is new UC (S_SF, Short_Float); + function To_SI is new UC (S_SI, Short_Integer); + function To_SSI is new UC (S_SSI, Short_Short_Integer); + function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned); + function To_SU is new UC (S_SU, UST.Short_Unsigned); + function To_U is new UC (S_U, UST.Unsigned); + function To_WC is new UC (S_WC, Wide_Character); + + ---------- + -- I_AD -- + ---------- + + function I_AD (Stream : access RST) return Fat_Pointer is + T : S_AD; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_AD (T); + end if; + end I_AD; + + ---------- + -- I_AS -- + ---------- + + function I_AS (Stream : access RST) return Thin_Pointer is + T : S_AS; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_AS (T); + end if; + end I_AS; + + --------- + -- I_B -- + --------- + + function I_B (Stream : access RST) return Boolean is + T : S_B; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return Boolean'Val (T (1)); + end if; + end I_B; + + --------- + -- I_C -- + --------- + + function I_C (Stream : access RST) return Character is + T : S_C; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_C (T); + end if; + end I_C; + + --------- + -- I_F -- + --------- + + function I_F (Stream : access RST) return Float is + T : S_F; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_F (T); + end if; + end I_F; + + --------- + -- I_I -- + --------- + + function I_I (Stream : access RST) return Integer is + T : S_I; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_I (T); + end if; + end I_I; + + ---------- + -- I_LF -- + ---------- + + function I_LF (Stream : access RST) return Long_Float is + T : S_LF; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LF (T); + end if; + end I_LF; + + ---------- + -- I_LI -- + ---------- + + function I_LI (Stream : access RST) return Long_Integer is + T : S_LI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LI (T); + end if; + end I_LI; + + ----------- + -- I_LLF -- + ----------- + + function I_LLF (Stream : access RST) return Long_Long_Float is + T : S_LLF; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LLF (T); + end if; + end I_LLF; + + ----------- + -- I_LLI -- + ----------- + + function I_LLI (Stream : access RST) return Long_Long_Integer is + T : S_LLI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LLI (T); + end if; + end I_LLI; + + ----------- + -- I_LLU -- + ----------- + + function I_LLU (Stream : access RST) return UST.Long_Long_Unsigned is + T : S_LLU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LLU (T); + end if; + end I_LLU; + + ---------- + -- I_LU -- + ---------- + + function I_LU (Stream : access RST) return UST.Long_Unsigned is + T : S_LU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LU (T); + end if; + end I_LU; + + ---------- + -- I_SF -- + ---------- + + function I_SF (Stream : access RST) return Short_Float is + T : S_SF; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SF (T); + end if; + end I_SF; + + ---------- + -- I_SI -- + ---------- + + function I_SI (Stream : access RST) return Short_Integer is + T : S_SI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SI (T); + end if; + end I_SI; + + ----------- + -- I_SSI -- + ----------- + + function I_SSI (Stream : access RST) return Short_Short_Integer is + T : S_SSI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SSI (T); + end if; + end I_SSI; + + ----------- + -- I_SSU -- + ----------- + + function I_SSU (Stream : access RST) return UST.Short_Short_Unsigned is + T : S_SSU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SSU (T); + end if; + end I_SSU; + + ---------- + -- I_SU -- + ---------- + + function I_SU (Stream : access RST) return UST.Short_Unsigned is + T : S_SU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SU (T); + end if; + end I_SU; + + --------- + -- I_U -- + --------- + + function I_U (Stream : access RST) return UST.Unsigned is + T : S_U; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_U (T); + end if; + end I_U; + + ---------- + -- I_WC -- + ---------- + + function I_WC (Stream : access RST) return Wide_Character is + T : S_WC; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_WC (T); + end if; + end I_WC; + + ---------- + -- W_AD -- + ---------- + + procedure W_AD (Stream : access RST; Item : in Fat_Pointer) is + T : constant S_AD := From_AD (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_AD; + + ---------- + -- W_AS -- + ---------- + + procedure W_AS (Stream : access RST; Item : in Thin_Pointer) is + T : constant S_AS := From_AS (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_AS; + + --------- + -- W_B -- + --------- + + procedure W_B (Stream : access RST; Item : in Boolean) is + T : S_B; + + begin + T (1) := Boolean'Pos (Item); + Ada.Streams.Write (Stream.all, T); + end W_B; + + --------- + -- W_C -- + --------- + + procedure W_C (Stream : access RST; Item : in Character) is + T : constant S_C := From_C (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_C; + + --------- + -- W_F -- + --------- + + procedure W_F (Stream : access RST; Item : in Float) is + T : constant S_F := From_F (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_F; + + --------- + -- W_I -- + --------- + + procedure W_I (Stream : access RST; Item : in Integer) is + T : constant S_I := From_I (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_I; + + ---------- + -- W_LF -- + ---------- + + procedure W_LF (Stream : access RST; Item : in Long_Float) is + T : constant S_LF := From_LF (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_LF; + + ---------- + -- W_LI -- + ---------- + + procedure W_LI (Stream : access RST; Item : in Long_Integer) is + T : constant S_LI := From_LI (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_LI; + + ----------- + -- W_LLF -- + ----------- + + procedure W_LLF (Stream : access RST; Item : in Long_Long_Float) is + T : constant S_LLF := From_LLF (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_LLF; + + ----------- + -- W_LLI -- + ----------- + + procedure W_LLI (Stream : access RST; Item : in Long_Long_Integer) is + T : constant S_LLI := From_LLI (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_LLI; + + ----------- + -- W_LLU -- + ----------- + + procedure W_LLU (Stream : access RST; Item : in UST.Long_Long_Unsigned) is + T : constant S_LLU := From_LLU (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_LLU; + + ---------- + -- W_LU -- + ---------- + + procedure W_LU (Stream : access RST; Item : in UST.Long_Unsigned) is + T : constant S_LU := From_LU (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_LU; + + ---------- + -- W_SF -- + ---------- + + procedure W_SF (Stream : access RST; Item : in Short_Float) is + T : constant S_SF := From_SF (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_SF; + + ---------- + -- W_SI -- + ---------- + + procedure W_SI (Stream : access RST; Item : in Short_Integer) is + T : constant S_SI := From_SI (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_SI; + + ----------- + -- W_SSI -- + ----------- + + procedure W_SSI (Stream : access RST; Item : in Short_Short_Integer) is + T : constant S_SSI := From_SSI (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_SSI; + + ----------- + -- W_SSU -- + ----------- + + procedure W_SSU (Stream : access RST; Item : in UST.Short_Short_Unsigned) is + T : constant S_SSU := From_SSU (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_SSU; + + ---------- + -- W_SU -- + ---------- + + procedure W_SU (Stream : access RST; Item : in UST.Short_Unsigned) is + T : constant S_SU := From_SU (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_SU; + + --------- + -- W_U -- + --------- + + procedure W_U (Stream : access RST; Item : in UST.Unsigned) is + T : constant S_U := From_U (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_U; + + ---------- + -- W_WC -- + ---------- + + procedure W_WC (Stream : access RST; Item : in Wide_Character) is + T : constant S_WC := From_WC (Item); + + begin + Ada.Streams.Write (Stream.all, T); + end W_WC; + +end System.Stream_Attributes; diff --git a/gcc/ada/s-stratt.ads b/gcc/ada/s-stratt.ads new file mode 100644 index 00000000000..66f617bedac --- /dev/null +++ b/gcc/ada/s-stratt.ads @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the implementations of the stream attributes for +-- elementary types. These are the subprograms that are directly accessed +-- by occurrences of the stream attributes where the type is elementary. + +-- We only provide the subprograms for the standard base types. For user +-- defined types, the subprogram for the corresponding root type is called +-- with an appropriate conversion. + +with System; +with System.Unsigned_Types; +with Ada.Streams; + +package System.Stream_Attributes is +pragma Preelaborate (Stream_Attributes); + + pragma Suppress (Accessibility_Check, Stream_Attributes); + -- No need to check accessibility on arguments of subprograms + + package UST renames System.Unsigned_Types; + + subtype RST is Ada.Streams.Root_Stream_Type'Class; + + -- Enumeration types are usually transferred using the routine for the + -- corresponding integer. The exception is that special routines are + -- provided for Boolean and the character types, in case the protocol + -- in use provides specially for these types. + + -- Access types use either a thin pointer (single address) or fat pointer + -- (double address) form. The following types are used to hold access + -- values using unchecked conversions. + + type Thin_Pointer is record + P1 : System.Address; + end record; + + type Fat_Pointer is record + P1 : System.Address; + P2 : System.Address; + end record; + + ------------------------------------ + -- Treatment of enumeration types -- + ------------------------------------ + + -- In this interface, there are no specific routines for general input + -- or output of enumeration types. Generally, enumeration types whose + -- representation is unsigned (no negative representation values) are + -- treated as unsigned integers, and enumeration types that do have + -- negative representation values are treated as signed integers. + + -- An exception is that there are specialized routines for Boolean, + -- Character, and Wide_Character types, but these specialized routines + -- are used only if the type in question has a standard representation. + -- For the case of a non-standard representation (one where the size of + -- the first subtype is specified, or where an enumeration representation + -- clause is given, these three types are treated like any other cases + -- of enumeration types, as described above. + -- for + + --------------------- + -- Input Functions -- + --------------------- + + -- Functions for S'Input attribute. These functions are also used for + -- S'Read, with the obvious transformation, since the input operation + -- is the same for all elementary types (no bounds or discriminants + -- are involved). + + function I_AD (Stream : access RST) return Fat_Pointer; + function I_AS (Stream : access RST) return Thin_Pointer; + function I_B (Stream : access RST) return Boolean; + function I_C (Stream : access RST) return Character; + function I_F (Stream : access RST) return Float; + function I_I (Stream : access RST) return Integer; + function I_LF (Stream : access RST) return Long_Float; + function I_LI (Stream : access RST) return Long_Integer; + function I_LLF (Stream : access RST) return Long_Long_Float; + function I_LLI (Stream : access RST) return Long_Long_Integer; + function I_LLU (Stream : access RST) return UST.Long_Long_Unsigned; + function I_LU (Stream : access RST) return UST.Long_Unsigned; + function I_SF (Stream : access RST) return Short_Float; + function I_SI (Stream : access RST) return Short_Integer; + function I_SSI (Stream : access RST) return Short_Short_Integer; + function I_SSU (Stream : access RST) return UST.Short_Short_Unsigned; + function I_SU (Stream : access RST) return UST.Short_Unsigned; + function I_U (Stream : access RST) return UST.Unsigned; + function I_WC (Stream : access RST) return Wide_Character; + + ----------------------- + -- Output Procedures -- + ----------------------- + + -- Procedures for S'Write attribute. These procedures are also used + -- for 'Output, since for elementary types there is no difference + -- between 'Write and 'Output because there are no discriminants + -- or bounds to be written. + + procedure W_AD (Stream : access RST; Item : in Fat_Pointer); + procedure W_AS (Stream : access RST; Item : in Thin_Pointer); + procedure W_B (Stream : access RST; Item : in Boolean); + procedure W_C (Stream : access RST; Item : in Character); + procedure W_F (Stream : access RST; Item : in Float); + procedure W_I (Stream : access RST; Item : in Integer); + procedure W_LF (Stream : access RST; Item : in Long_Float); + procedure W_LI (Stream : access RST; Item : in Long_Integer); + procedure W_LLF (Stream : access RST; Item : in Long_Long_Float); + procedure W_LLI (Stream : access RST; Item : in Long_Long_Integer); + procedure W_LLU (Stream : access RST; Item : in UST.Long_Long_Unsigned); + procedure W_LU (Stream : access RST; Item : in UST.Long_Unsigned); + procedure W_SF (Stream : access RST; Item : in Short_Float); + procedure W_SI (Stream : access RST; Item : in Short_Integer); + procedure W_SSI (Stream : access RST; Item : in Short_Short_Integer); + procedure W_SSU (Stream : access RST; Item : in UST.Short_Short_Unsigned); + procedure W_SU (Stream : access RST; Item : in UST.Short_Unsigned); + procedure W_U (Stream : access RST; Item : in UST.Unsigned); + procedure W_WC (Stream : access RST; Item : in Wide_Character); + +private + pragma Inline (I_AD); + pragma Inline (I_AS); + pragma Inline (I_B); + pragma Inline (I_C); + pragma Inline (I_F); + pragma Inline (I_I); + pragma Inline (I_LF); + pragma Inline (I_LI); + pragma Inline (I_LLF); + pragma Inline (I_LLI); + pragma Inline (I_LLU); + pragma Inline (I_LU); + pragma Inline (I_SF); + pragma Inline (I_SI); + pragma Inline (I_SSI); + pragma Inline (I_SSU); + pragma Inline (I_SU); + pragma Inline (I_U); + pragma Inline (I_WC); + + pragma Inline (W_AD); + pragma Inline (W_AS); + pragma Inline (W_B); + pragma Inline (W_C); + pragma Inline (W_F); + pragma Inline (W_I); + pragma Inline (W_LF); + pragma Inline (W_LI); + pragma Inline (W_LLF); + pragma Inline (W_LLI); + pragma Inline (W_LLU); + pragma Inline (W_LU); + pragma Inline (W_SF); + pragma Inline (W_SI); + pragma Inline (W_SSI); + pragma Inline (W_SSU); + pragma Inline (W_SU); + pragma Inline (W_U); + pragma Inline (W_WC); + +end System.Stream_Attributes; diff --git a/gcc/ada/s-strops.adb b/gcc/ada/s-strops.adb new file mode 100644 index 00000000000..35dac03383b --- /dev/null +++ b/gcc/ada/s-strops.adb @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- 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 System.String_Ops is + + ---------------- + -- Str_Concat -- + ---------------- + + function Str_Concat (X, Y : String) return String is + begin + if X'Length <= 0 then + return Y; + + else + declare + L : constant Natural := X'Length + Y'Length; + R : String (X'First .. X'First + L - 1); + + begin + R (X'Range) := X; + R (X'First + X'Length .. R'Last) := Y; + return R; + end; + end if; + end Str_Concat; + + ------------------- + -- Str_Concat_CC -- + ------------------- + + function Str_Concat_CC (X, Y : Character) return String is + R : String (1 .. 2); + + begin + R (1) := X; + R (2) := Y; + return R; + end Str_Concat_CC; + + ------------------- + -- Str_Concat_CS -- + ------------------- + + function Str_Concat_CS (X : Character; Y : String) return String is + R : String (1 .. Y'Length + 1); + + begin + R (1) := X; + R (2 .. R'Last) := Y; + return R; + end Str_Concat_CS; + + ------------------- + -- Str_Concat_SC -- + ------------------- + + function Str_Concat_SC (X : String; Y : Character) return String is + begin + if X'Length <= 0 then + return (1 => Y); + + else + declare + R : String (X'First .. X'Last + 1); + + begin + R (X'Range) := X; + R (R'Last) := Y; + return R; + end; + end if; + end Str_Concat_SC; + + --------------- + -- Str_Equal -- + --------------- + + function Str_Equal (A, B : String) return Boolean is + begin + if A'Length /= B'Length then + return False; + + else + for J in A'Range loop + if A (J) /= B (J + (B'First - A'First)) then + return False; + end if; + end loop; + + return True; + end if; + end Str_Equal; + + ------------------- + -- Str_Normalize -- + ------------------- + + procedure Str_Normalize (A : in out String) is + begin + for J in A'Range loop + A (J) := Character'Last; + end loop; + end Str_Normalize; + + ------------------------ + -- Wide_Str_Normalize -- + ------------------------ + + procedure Wide_Str_Normalize (A : in out Wide_String) is + begin + for J in A'Range loop + A (J) := Wide_Character'Last; + end loop; + end Wide_Str_Normalize; + +end System.String_Ops; diff --git a/gcc/ada/s-strops.ads b/gcc/ada/s-strops.ads new file mode 100644 index 00000000000..9a2846f75e3 --- /dev/null +++ b/gcc/ada/s-strops.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- 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 contains functions for runtime operations on strings + +package System.String_Ops is +pragma Pure (String_Ops); + + function Str_Concat (X, Y : String) return String; + -- Concatenate two strings and return resulting string + + function Str_Concat_SC (X : String; Y : Character) return String; + -- Concatenate string and character + + function Str_Concat_CS (X : Character; Y : String) return String; + -- Concatenate character and string + + function Str_Concat_CC (X, Y : Character) return String; + -- Concatenate two characters + + function Str_Equal (A, B : String) return Boolean; + -- Compare two strings for equality + + procedure Str_Normalize (A : in out String); + -- Initialize String object if pragma Normalize_Scalars is in effect. + + procedure Wide_Str_Normalize (A : in out Wide_String); + -- Ditto for Wide_String. + + pragma Inline (Str_Normalize); + pragma Inline (Wide_Str_Normalize); +end System.String_Ops; diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb new file mode 100644 index 00000000000..1f75f741feb --- /dev/null +++ b/gcc/ada/s-taasde.adb @@ -0,0 +1,384 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies, 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Ada.Exceptions; +-- Used for Raise_Exception + +with System.Task_Primitives.Operations; +-- Used for Write_Lock, +-- Unlock, +-- Self, +-- Monotonic_Clock, +-- Self, +-- Timed_Sleep, +-- Wakeup, +-- Yield + +with System.Tasking.Utilities; +-- Used for Make_Independent + +with System.Tasking.Initialization; +-- Used for Defer_Abort +-- Undefer_Abort + +with System.Tasking.Debug; +-- Used for Trace + +with System.OS_Primitives; +-- used for Max_Sensible_Delay + +with Ada.Task_Identification; +-- used for Task_ID type + +with Unchecked_Conversion; + +package body System.Tasking.Async_Delays is + + package STPO renames System.Task_Primitives.Operations; + package ST renames System.Tasking; + package STU renames System.Tasking.Utilities; + package STI renames System.Tasking.Initialization; + package OSP renames System.OS_Primitives; + + function To_System is new Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_ID); + + Timer_Server_ID : ST.Task_ID; + + Timer_Attention : Boolean := False; + pragma Atomic (Timer_Attention); + + task Timer_Server is + pragma Interrupt_Priority (System.Any_Priority'Last); + end Timer_Server; + + -- The timer queue is a circular doubly linked list, ordered by absolute + -- wakeup time. The first item in the queue is Timer_Queue.Succ. + -- It is given a Resume_Time that is larger than any legitimate wakeup + -- time, so that the ordered insertion will always stop searching when it + -- gets back to the queue header block. + + Timer_Queue : aliased Delay_Block; + + ------------------------ + -- Cancel_Async_Delay -- + ------------------------ + + -- This should (only) be called from the compiler-generated cleanup routine + -- for an async. select statement with delay statement as trigger. The + -- effect should be to remove the delay from the timer queue, and exit one + -- ATC nesting level. + -- The usage and logic are similar to Cancel_Protected_Entry_Call, but + -- simplified because this is not a true entry call. + + procedure Cancel_Async_Delay (D : Delay_Block_Access) is + Dpred : Delay_Block_Access; + Dsucc : Delay_Block_Access; + + begin + -- Note that we mark the delay as being cancelled + -- using a level value that is reserved. + + -- make this operation idempotent + + if D.Level = ATC_Level_Infinity then + return; + end if; + + D.Level := ATC_Level_Infinity; + + -- remove self from timer queue + + STI.Defer_Abort_Nestable (D.Self_Id); + STPO.Write_Lock (Timer_Server_ID); + Dpred := D.Pred; + Dsucc := D.Succ; + Dpred.Succ := Dsucc; + Dsucc.Pred := Dpred; + D.Succ := D; + D.Pred := D; + STPO.Unlock (Timer_Server_ID); + + -- Note that the above deletion code is required to be + -- idempotent, since the block may have been dequeued + -- previously by the Timer_Server. + + -- leave the asynchronous select + + STPO.Write_Lock (D.Self_Id); + STU.Exit_One_ATC_Level (D.Self_Id); + STPO.Unlock (D.Self_Id); + STI.Undefer_Abort_Nestable (D.Self_Id); + end Cancel_Async_Delay; + + --------------------------- + -- Enqueue_Time_Duration -- + --------------------------- + + function Enqueue_Duration + (T : in Duration; + D : Delay_Block_Access) + return Boolean + is + begin + if T <= 0.0 then + D.Timed_Out := True; + STPO.Yield; + return False; + + else + STI.Defer_Abort (STPO.Self); + Time_Enqueue + (STPO.Monotonic_Clock + + Duration'Min (T, OSP.Max_Sensible_Delay), D); + return True; + end if; + end Enqueue_Duration; + + ------------------ + -- Time_Enqueue -- + ------------------ + + -- Allocate a queue element for the wakeup time T and put it in the + -- queue in wakeup time order. Assume we are on an asynchronous + -- select statement with delay trigger. Put the calling task to + -- sleep until either the delay expires or is cancelled. + + -- We use one entry call record for this delay, since we have + -- to increment the ATC nesting level, but since it is not a + -- real entry call we do not need to use any of the fields of + -- the call record. The following code implements a subset of + -- the actions for the asynchronous case of Protected_Entry_Call, + -- much simplified since we know this never blocks, and does not + -- have the full semantics of a protected entry call. + + procedure Time_Enqueue + (T : Duration; + D : Delay_Block_Access) + is + Self_Id : constant Task_ID := STPO.Self; + Q : Delay_Block_Access; + + use type ST.Task_ID; + -- for visibility of operator "=" + + begin + pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P')); + pragma Assert (Self_Id.Deferral_Level = 1, + "async delay from within abort-deferred region"); + + if Self_Id.ATC_Nesting_Level = ATC_Level'Last then + Ada.Exceptions.Raise_Exception (Storage_Error'Identity, + "not enough ATC nesting levels"); + end if; + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "ASD: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + D.Level := Self_Id.ATC_Nesting_Level; + D.Self_Id := Self_Id; + D.Resume_Time := T; + + STI.Defer_Abort (Self_Id); + STPO.Write_Lock (Timer_Server_ID); + + -- Previously, there was code here to dynamically create + -- the Timer_Server task, if one did not already exist. + -- That code had a timing window that could allow multiple + -- timer servers to be created. Luckily, the need for + -- postponing creation of the timer server should now be + -- gone, since this package will only be linked in if + -- there are calls to enqueue calls on the timer server. + + -- Insert D in the timer queue, at the position determined + -- by the wakeup time T. + + Q := Timer_Queue.Succ; + + while Q.Resume_Time < T loop + Q := Q.Succ; + end loop; + + -- Q is the block that has Resume_Time equal to or greater than + -- T. After the insertion we want Q to be the successor of D. + + D.Succ := Q; + D.Pred := Q.Pred; + D.Pred.Succ := D; + Q.Pred := D; + + -- If the new element became the head of the queue, + -- signal the Timer_Server to wake up. + + if Timer_Queue.Succ = D then + Timer_Attention := True; + STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep); + end if; + + STPO.Unlock (Timer_Server_ID); + STI.Undefer_Abort (Self_Id); + end Time_Enqueue; + + --------------- + -- Timed_Out -- + --------------- + + function Timed_Out (D : Delay_Block_Access) return Boolean is + begin + return D.Timed_Out; + end Timed_Out; + + ------------------ + -- Timer_Server -- + ------------------ + + task body Timer_Server is + Next_Wakeup_Time : Duration := Duration'Last; + Timedout : Boolean; + Yielded : Boolean; + Now : Duration; + Dequeued, + Tpred, + Tsucc : Delay_Block_Access; + Dequeued_Task : Task_ID; + + -- Initialize_Timer_Queue returns null, but has critical side-effects + -- of initializing the timer queue. + + begin + Timer_Server_ID := STPO.Self; + STU.Make_Independent; + + -- Initialize the timer queue to empty, and make the wakeup time of the + -- header node be larger than any real wakeup time we will ever use. + + loop + STI.Defer_Abort (Timer_Server_ID); + STPO.Write_Lock (Timer_Server_ID); + + -- The timer server needs to catch pending aborts after finalization + -- of library packages. If it doesn't poll for it, the server will + -- sometimes hang. + + if not Timer_Attention then + Timer_Server_ID.Common.State := ST.Timer_Server_Sleep; + + if Next_Wakeup_Time = Duration'Last then + Timer_Server_ID.User_State := 1; + Next_Wakeup_Time := + STPO.Monotonic_Clock + OSP.Max_Sensible_Delay; + + else + Timer_Server_ID.User_State := 2; + end if; + + STPO.Timed_Sleep + (Timer_Server_ID, Next_Wakeup_Time, + OSP.Absolute_RT, ST.Timer_Server_Sleep, + Timedout, Yielded); + Timer_Server_ID.Common.State := ST.Runnable; + end if; + + -- Service all of the wakeup requests on the queue whose times have + -- been reached, and update Next_Wakeup_Time to next wakeup time + -- after that (the wakeup time of the head of the queue if any, else + -- a time far in the future). + + Timer_Server_ID.User_State := 3; + Timer_Attention := False; + + Now := STPO.Monotonic_Clock; + + while Timer_Queue.Succ.Resume_Time <= Now loop + + -- Dequeue the waiting task from the front of the queue. + + pragma Debug (System.Tasking.Debug.Trace + ("Timer service: waking up waiting task", 'E')); + + Dequeued := Timer_Queue.Succ; + Timer_Queue.Succ := Dequeued.Succ; + Dequeued.Succ.Pred := Dequeued.Pred; + Dequeued.Succ := Dequeued; + Dequeued.Pred := Dequeued; + + -- We want to abort the queued task to the level of the async. + -- select statement with the delay. To do that, we need to lock + -- the ATCB of that task, but to avoid deadlock we need to release + -- the lock of the Timer_Server. This leaves a window in which + -- another task might perform an enqueue or dequeue operation on + -- the timer queue, but that is OK because we always restart the + -- next iteration at the head of the queue. + + STPO.Unlock (Timer_Server_ID); + STPO.Write_Lock (Dequeued.Self_Id); + Dequeued_Task := Dequeued.Self_Id; + Dequeued.Timed_Out := True; + STI.Locked_Abort_To_Level + (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1); + STPO.Unlock (Dequeued_Task); + STPO.Write_Lock (Timer_Server_ID); + end loop; + + Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time; + + -- Service returns the Next_Wakeup_Time. + -- The Next_Wakeup_Time is either an infinity (no delay request) + -- or the wakeup time of the queue head. This value is used for + -- an actual delay in this server. + + STPO.Unlock (Timer_Server_ID); + STI.Undefer_Abort (Timer_Server_ID); + end loop; + end Timer_Server; + + ------------------------------ + -- Package Body Elaboration -- + ------------------------------ + +begin + Timer_Queue.Succ := Timer_Queue'Unchecked_Access; + Timer_Queue.Pred := Timer_Queue'Unchecked_Access; + Timer_Queue.Resume_Time := Duration'Last; + Timer_Server_ID := To_System (Timer_Server'Identity); +end System.Tasking.Async_Delays; diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads new file mode 100644 index 00000000000..f83c7222f38 --- /dev/null +++ b/gcc/ada/s-taasde.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1998-1999 Ada Core Technologies, 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 contains the procedures to implements timeouts (delays) on +-- asynchronous select statements. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +package System.Tasking.Async_Delays is + + -- Suppose the following source code is given: + + -- select delay When; + -- ...continuation for timeout case... + -- then abort + -- ...abortable part... + -- end select; + + -- The compiler should expand this to the following: + + -- declare + -- DB : aliased Delay_Block; + -- begin + -- if System.Tasking.Async_Delays.Enqueue_Duration + -- (When, DB'Unchecked_Access) + -- then + -- begin + -- A101b : declare + -- procedure _clean is + -- begin + -- System.Tasking.Async_Delays.Cancel_Async_Delay + -- (DB'Unchecked_Access); + -- return; + -- end _clean; + -- begin + -- abort_undefer.all; + -- ...abortable part... + -- exception + -- when all others => + -- declare + -- E105b : exception_occurrence; + -- begin + -- save_occurrence (E105b, get_current_excep.all.all); + -- _clean; + -- reraise_occurrence_no_defer (E105b); + -- end; + -- at end + -- _clean; + -- end A101b; + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- end; + -- end if; + -- + -- if Timed_Out (DB'Unchecked_Access) then + -- ...continuation for timeout case... + -- end if; + -- end; + + ----------------- + -- Delay_Block -- + ----------------- + + type Delay_Block is limited private; + type Delay_Block_Access is access all Delay_Block; + + function Enqueue_Duration + (T : in Duration; + D : Delay_Block_Access) return Boolean; + -- Enqueue the specified relative delay. Returns True if the delay has + -- been enqueued, False if it has already expired. + -- If the delay has been enqueued, abortion is deferred. + + procedure Cancel_Async_Delay (D : Delay_Block_Access); + -- Cancel the specified asynchronous delay + + function Timed_Out (D : Delay_Block_Access) return Boolean; + pragma Inline (Timed_Out); + -- Return True if the delay specified in D has timed out + + -- There are child units for delays on Ada.Calendar.Time and + -- Ada.Real_Time.Time, so that an application will not need to link in + -- features that is not using. + +private + + type Delay_Block is record + Self_Id : Task_ID; + -- ID of the calling task + + Level : ATC_Level_Base; + -- Normally Level is the ATC nesting level of the + -- async. select statement to which this delay belongs, but + -- after a call has been dequeued we set it to + -- ATC_Level_Infinity so that the Cancel operation can + -- detect repeated calls, and act idempotently. + + Resume_Time : Duration; + -- The absolute wake up time, represented as Duration + + Timed_Out : Boolean := False; + -- Set to true if the delay has timed out + + Succ, Pred : Delay_Block_Access; + -- A double linked list + end record; + + -- The above "overlaying" of Self_ID and Level to hold other + -- data that has a non-overlapping lifetime is an unabashed + -- hack to save memory. + + procedure Time_Enqueue + (T : Duration; + D : Delay_Block_Access); + pragma Inline (Time_Enqueue); + -- Used by the child units to enqueue delays on the timer queue + -- implemented in the body of this package. + +end System.Tasking.Async_Delays; diff --git a/gcc/ada/s-tadeca.adb b/gcc/ada/s-tadeca.adb new file mode 100644 index 00000000000..acf479c4359 --- /dev/null +++ b/gcc/ada/s-tadeca.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- +-- E N Q U E U E _ C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1998-1999 Ada Core Technologies, 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 Ada.Calendar.Delays; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +function System.Tasking.Async_Delays.Enqueue_Calendar + (T : in Ada.Calendar.Time; + D : Delay_Block_Access) return Boolean +is + use type Ada.Calendar.Time; +begin + if T <= Ada.Calendar.Clock then + D.Timed_Out := True; + System.Task_Primitives.Operations.Yield; + return False; + end if; + + System.Tasking.Initialization.Defer_Abort + (System.Task_Primitives.Operations.Self); + Time_Enqueue (Ada.Calendar.Delays.To_Duration (T), D); + return True; +end System.Tasking.Async_Delays.Enqueue_Calendar; diff --git a/gcc/ada/s-tadeca.ads b/gcc/ada/s-tadeca.ads new file mode 100644 index 00000000000..cf0a9180d17 --- /dev/null +++ b/gcc/ada/s-tadeca.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- +-- E N Q U E U E _ C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1998-1999 Ada Core Technologies, 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- See comments in package System.Tasking.Async_Delays + +with Ada.Calendar; +function System.Tasking.Async_Delays.Enqueue_Calendar + (T : in Ada.Calendar.Time; + D : Delay_Block_Access) return Boolean; diff --git a/gcc/ada/s-tadert.adb b/gcc/ada/s-tadert.adb new file mode 100644 index 00000000000..a44a810adff --- /dev/null +++ b/gcc/ada/s-tadert.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- +-- E N Q U E U E _ R T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1998-1999 Ada Core Technologies, 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 Ada.Real_Time; +with Ada.Real_Time.Delays; +with System.Task_Primitives.Operations; +with System.Tasking.Initialization; + +function System.Tasking.Async_Delays.Enqueue_RT + (T : in Ada.Real_Time.Time; + D : Delay_Block_Access) return Boolean +is + use type Ada.Real_Time.Time; -- for "=" operator +begin + if T <= Ada.Real_Time.Clock then + D.Timed_Out := True; + System.Task_Primitives.Operations.Yield; + return False; + end if; + + System.Tasking.Initialization.Defer_Abort + (System.Task_Primitives.Operations.Self); + Time_Enqueue (Ada.Real_Time.Delays.To_Duration (T), D); + return True; +end System.Tasking.Async_Delays.Enqueue_RT; diff --git a/gcc/ada/s-tadert.ads b/gcc/ada/s-tadert.ads new file mode 100644 index 00000000000..12e3e592f80 --- /dev/null +++ b/gcc/ada/s-tadert.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S . -- +-- E N Q U E U E _ R T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1998-1999 Ada Core Technologies, 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- See comments in package System.Tasking.Async_Delays + +with Ada.Real_Time; +function System.Tasking.Async_Delays.Enqueue_RT + (T : in Ada.Real_Time.Time; + D : Delay_Block_Access) return Boolean; diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb new file mode 100644 index 00000000000..bf9afbaedad --- /dev/null +++ b/gcc/ada/s-taenca.adb @@ -0,0 +1,713 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.36 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides internal RTS calls implementing operations +-- that apply to general entry calls, that is, calls to either +-- protected or task entries. + +-- These declarations are not part of the GNARL interface + +with System.Task_Primitives.Operations; +-- used for STPO.Write_Lock +-- Unlock +-- STPO.Get_Priority +-- Sleep +-- Timed_Sleep + +with System.Tasking.Initialization; +-- used for Change_Base_Priority +-- Poll_Base_Priority_Change_At_Entry_Call +-- Dynamic_Priority_Support +-- Defer_Abort/Undefer_Abort + +with System.Tasking.Protected_Objects.Entries; +-- used for To_Protection + +with System.Tasking.Protected_Objects.Operations; +-- used for PO_Service_Entries + +with System.Tasking.Queuing; +-- used for Requeue_Call_With_New_Prio +-- Onqueue +-- Dequeue_Call + +with System.Tasking.Utilities; +-- used for Exit_One_ATC_Level + +package body System.Tasking.Entry_Calls is + + package STPO renames System.Task_Primitives.Operations; + + use System.Task_Primitives; + use System.Tasking.Protected_Objects.Entries; + use System.Tasking.Protected_Objects.Operations; + + -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock + -- internally. Those operations will raise Program_Error, which + -- we do are not prepared to handle inside the RTS. Instead, use + -- System.Task_Primitives lock operations directly on Protection.L. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Lock_Server (Entry_Call : Entry_Call_Link); + -- This locks the server targeted by Entry_Call. + -- + -- This may be a task or a protected object, + -- depending on the target of the original call or any subsequent + -- requeues. + -- + -- This routine is needed because the field specifying the server + -- for this call must be protected by the server's mutex. If it were + -- protected by the caller's mutex, accessing the server's queues would + -- require locking the caller to get the server, locking the server, + -- and then accessing the queues. This involves holding two ATCB + -- locks at once, something which we can guarantee that it will always + -- be done in the same order, or locking a protected object while we + -- hold an ATCB lock, something which is not permitted. Since + -- the server cannot be obtained reliably, it must be obtained unreliably + -- and then checked again once it has been locked. + + procedure Unlock_Server (Entry_Call : Entry_Call_Link); + -- STPO.Unlock the server targeted by Entry_Call. The server must + -- be locked before calling this. + + procedure Unlock_And_Update_Server + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + -- Similar to Unlock_Server, but services entry calls if the + -- server is a protected object. + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Pending_Actions_For_Entry_Call); + -- This procedure performs priority change of a queued call and + -- dequeuing of an entry call when an the call is cancelled. + -- If the call is dequeued the state should be set to Cancelled. + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); + -- Has to be called with the Self_ID's ATCB write-locked. + -- May temporariliy release the lock. + + --------------------- + -- Check_Exception -- + --------------------- + + -- Raise any pending exception from the Entry_Call. + + -- This should be called at the end of every compiler interface + -- procedure that implements an entry call. + + -- In principle, the caller should not be abort-deferred (unless + -- the application program violates the Ada language rules by doing + -- entry calls from within protected operations -- an erroneous practice + -- apparently followed with success by some adventurous GNAT users). + -- Absolutely, the caller should not be holding any locks, or there + -- will be deadlock. + + procedure Check_Exception + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + use type Ada.Exceptions.Exception_Id; + + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); + + E : constant Ada.Exceptions.Exception_Id := + Entry_Call.Exception_To_Raise; + begin + -- pragma Assert (Self_ID.Deferral_Level = 0); + -- The above may be useful for debugging, but the Florist packages + -- contain critical sections that defer abort and then do entry calls, + -- which causes the above Assert to trip. + + if E /= Ada.Exceptions.Null_Id then + Internal_Raise (E); + end if; + end Check_Exception; + + ----------------------------------------- + -- Check_Pending_Actions_For_Entry_Call -- + ----------------------------------------- + + -- Call only with abort deferred and holding lock of Self_ID. This + -- is a bit of common code for all entry calls. The effect is to do + -- any deferred base priority change operation, in case some other + -- task called STPO.Set_Priority while the current task had abort deferred, + -- and to dequeue the call if the call has been aborted. + + procedure Check_Pending_Actions_For_Entry_Call + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID = Entry_Call.Self); + + Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call); + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then Entry_Call.State = Now_Abortable + then + STPO.Unlock (Self_ID); + Lock_Server (Entry_Call); + + if Queuing.Onqueue (Entry_Call) + and then Entry_Call.State = Now_Abortable + then + Queuing.Dequeue_Call (Entry_Call); + + if Entry_Call.Cancellation_Attempted then + Entry_Call.State := Cancelled; + else + Entry_Call.State := Done; + end if; + + Unlock_And_Update_Server (Self_ID, Entry_Call); + + else + Unlock_Server (Entry_Call); + end if; + + STPO.Write_Lock (Self_ID); + end if; + end Check_Pending_Actions_For_Entry_Call; + + ----------------- + -- Lock_Server -- + ----------------- + + -- This should only be called by the Entry_Call.Self. + -- It should be holding no other ATCB locks at the time. + + procedure Lock_Server (Entry_Call : Entry_Call_Link) is + Test_Task : Task_ID; + Test_PO : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Failures : Integer := 0; + + begin + Test_Task := Entry_Call.Called_Task; + + loop + if Test_Task = null then + + -- Entry_Call was queued on a protected object, + -- or in transition, when we last fetched Test_Task. + + Test_PO := To_Protection (Entry_Call.Called_PO); + + if Test_PO = null then + + -- We had very bad luck, interleaving with TWO different + -- requeue operations. Go around the loop and try again. + + STPO.Yield; + + else + Lock_Entries (Test_PO, Ceiling_Violation); + + -- ???? + -- The following code allows Lock_Server to be called + -- when cancelling a call, to allow for the possibility + -- that the priority of the caller has been raised + -- beyond that of the protected entry call by + -- Ada.Dynamic_Priorities.STPO.Set_Priority. + + -- If the current task has a higher priority than the ceiling + -- of the protected object, temporarily lower it. It will + -- be reset in Unlock. + + if Ceiling_Violation then + declare + Current_Task : Task_ID := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + STPO.Write_Lock (Current_Task); + Old_Base_Priority := Current_Task.Common.Base_Priority; + Current_Task.New_Base_Priority := Test_PO.Ceiling; + System.Tasking.Initialization.Change_Base_Priority + (Current_Task); + STPO.Unlock (Current_Task); + + -- Following lock should not fail + + Lock_Entries (Test_PO); + + Test_PO.Old_Base_Priority := Old_Base_Priority; + Test_PO.Pending_Action := True; + end; + end if; + + exit when To_Address (Test_PO) = Entry_Call.Called_PO; + Unlock_Entries (Test_PO); + end if; + + else + STPO.Write_Lock (Test_Task); + exit when Test_Task = Entry_Call.Called_Task; + STPO.Unlock (Test_Task); + end if; + + Test_Task := Entry_Call.Called_Task; + Failures := Failures + 1; + pragma Assert (Failures <= 5); + end loop; + end Lock_Server; + + --------------------------------------------- + -- Poll_Base_Priority_Change_At_Entry_Call -- + --------------------------------------------- + + -- A specialized version of Poll_Base_Priority_Change, + -- that does the optional entry queue reordering. + + procedure Poll_Base_Priority_Change_At_Entry_Call + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + begin + if Initialization.Dynamic_Priority_Support + and then Self_ID.Pending_Priority_Change + then + -- Check for ceiling violations ??? + + Self_ID.Pending_Priority_Change := False; + + if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then + STPO.Unlock (Self_ID); + STPO.Yield; + STPO.Write_Lock (Self_ID); + + else + if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then + + -- Raising priority + + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + + else + -- Lowering priority + + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + STPO.Unlock (Self_ID); + STPO.Yield; + STPO.Write_Lock (Self_ID); + end if; + end if; + + -- Requeue the entry call at the new priority. + -- We need to requeue even if the new priority is the same than + -- the previous (see ACVC cxd4006). + + STPO.Unlock (Self_ID); + Lock_Server (Entry_Call); + Queuing.Requeue_Call_With_New_Prio + (Entry_Call, STPO.Get_Priority (Self_ID)); + Unlock_And_Update_Server (Self_ID, Entry_Call); + STPO.Write_Lock (Self_ID); + end if; + end Poll_Base_Priority_Change_At_Entry_Call; + + -------------------- + -- Reset_Priority -- + -------------------- + + -- Reset the priority of a task completing an accept statement to + -- the value it had before the call. + + procedure Reset_Priority + (Acceptor_Prev_Priority : Rendezvous_Priority; + Acceptor : Task_ID) is + begin + if Acceptor_Prev_Priority /= Priority_Not_Boosted then + STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, + Loss_Of_Inheritance => True); + end if; + end Reset_Priority; + + -- ??? + -- Check why we don't need any kind of lock to do this. + -- Do we limit this kind of "active" priority change to be done + -- by the task for itself only? + + ------------------------------ + -- Try_To_Cancel_Entry_Call -- + ------------------------------ + + -- This is used to implement the Cancel_Task_Entry_Call and + -- Cancel_Protected_Entry_Call. + -- Try to cancel async. entry call. + -- Effect includes Abort_To_Level and Wait_For_Completion. + -- Cancelled = True iff the cancelation was successful, i.e., + -- the call was not Done before this call. + -- On return, the call is off-queue and the ATC level is reduced by one. + + procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is + Entry_Call : Entry_Call_Link; + Self_ID : constant Task_ID := STPO.Self; + + use type Ada.Exceptions.Exception_Id; + + begin + Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + + -- Experimentation has shown that abort is sometimes (but not + -- always) already deferred when Cancel_X_Entry_Call is called. + -- That may indicate an error. Find out what is going on. ??? + + pragma Assert (Entry_Call.Mode = Asynchronous_Call); + pragma Assert (Self_ID = Self); + + Initialization.Defer_Abort_Nestable (Self_ID); + STPO.Write_Lock (Self_ID); + Entry_Call.Cancellation_Attempted := True; + + if Self_ID.Pending_ATC_Level >= Entry_Call.Level then + Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; + end if; + + Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call); + STPO.Unlock (Self_ID); + Succeeded := Entry_Call.State = Cancelled; + + if Succeeded then + Initialization.Undefer_Abort_Nestable (Self_ID); + else + -- ???? + + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- Ideally, abort should no longer be deferred at this + -- point, so we should be able to call Check_Exception. + -- The loop below should be considered temporary, + -- to work around the possiblility that abort may be deferred + -- more than one level deep. + + if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then + while Self_ID.Deferral_Level > 0 loop + System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); + end loop; + + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end if; + end if; + end Try_To_Cancel_Entry_Call; + + ------------------------------ + -- Unlock_And_Update_Server -- + ------------------------------ + + procedure Unlock_And_Update_Server + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + Called_PO : Protection_Entries_Access; + Caller : Task_ID; + + begin + if Entry_Call.Called_Task /= null then + STPO.Unlock (Entry_Call.Called_Task); + else + Called_PO := To_Protection (Entry_Call.Called_PO); + PO_Service_Entries (Self_ID, Called_PO); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + end if; + + Unlock_Entries (Called_PO); + end if; + end Unlock_And_Update_Server; + + ------------------- + -- Unlock_Server -- + ------------------- + + procedure Unlock_Server (Entry_Call : Entry_Call_Link) is + Caller : Task_ID; + Called_PO : Protection_Entries_Access; + + begin + if Entry_Call.Called_Task /= null then + STPO.Unlock (Entry_Call.Called_Task); + else + Called_PO := To_Protection (Entry_Call.Called_PO); + + if Called_PO.Pending_Action then + Called_PO.Pending_Action := False; + Caller := STPO.Self; + STPO.Write_Lock (Caller); + Caller.New_Base_Priority := Called_PO.Old_Base_Priority; + Initialization.Change_Base_Priority (Caller); + STPO.Unlock (Caller); + end if; + + Unlock_Entries (Called_PO); + end if; + end Unlock_Server; + + ------------------------- + -- Wait_For_Completion-- + ------------------------- + + -- Call this only when holding Self_ID locked + + -- If this is a conditional call, it should be cancelled when it + -- becomes abortable. This is checked in the loop below. + + -- We do the same thing for Asynchronous_Call. Executing the following + -- loop will clear the Pending_Action field if there is no + -- Pending_Action. We want the call made from Cancel_Task_Entry_Call + -- to check the abortion level so that we make sure that the Cancelled + -- field reflect the status of an Asynchronous_Call properly. + -- This problem came up when the triggered statement and the abortable + -- part depend on entries of the same task. When a cancellation is + -- delivered, Undefer_Abort in the call made from abortable part + -- sets the Pending_Action bit to false. However, the call is actually + -- made to cancel the Asynchronous Call so that we need to check its + -- status here again. Otherwise we may end up waiting for a cancelled + -- call forever. + + -- ????? ......... + -- Recheck the logic of the above old comment. It may be stale. + + procedure Wait_For_Completion + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID = Entry_Call.Self); + Self_ID.Common.State := Entry_Caller_Sleep; + + loop + Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call); + exit when Entry_Call.State >= Done; + STPO.Sleep (Self_ID, Entry_Caller_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_ID); + end Wait_For_Completion; + + -------------------------------------- + -- Wait_For_Completion_With_Timeout -- + -------------------------------------- + + -- This routine will lock Self_ID. + + -- This procedure waits for the entry call to + -- be served, with a timeout. It tries to cancel the + -- call if the timeout expires before the call is served. + + -- If we wake up from the timed sleep operation here, + -- it may be for several possible reasons: + + -- 1) The entry call is done being served. + -- 2) There is an abort or priority change to be served. + -- 3) The timeout has expired (Timedout = True) + -- 4) There has been a spurious wakeup. + + -- Once the timeout has expired we may need to continue to wait if + -- the call is already being serviced. In that case, we want to go + -- back to sleep, but without any timeout. The variable Timedout is + -- used to control this. If the Timedout flag is set, we do not need + -- to STPO.Sleep with a timeout. We just sleep until we get a wakeup for + -- some status change. + + -- The original call may have become abortable after waking up. + -- We want to check Check_Pending_Actions_For_Entry_Call again + -- in any case. + + procedure Wait_For_Completion_With_Timeout + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes) + is + Timedout : Boolean := False; + Yielded : Boolean := False; + + use type Ada.Exceptions.Exception_Id; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + STPO.Write_Lock (Self_ID); + + pragma Assert (Entry_Call.Self = Self_ID); + pragma Assert (Entry_Call.Mode = Timed_Call); + Self_ID.Common.State := Entry_Caller_Sleep; + + -- Looping is necessary in case the task wakes up early from the + -- timed sleep, due to a "spurious wakeup". Spurious wakeups are + -- a weakness of POSIX condition variables. A thread waiting for + -- a condition variable is allowed to wake up at any time, not just + -- when the condition is signaled. See the same loop in the + -- ordinary Wait_For_Completion, above. + + loop + Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call); + exit when Entry_Call.State >= Done; + + STPO.Timed_Sleep (Self_ID, Wakeup_Time, Mode, + Entry_Caller_Sleep, Timedout, Yielded); + + if Timedout then + + -- Try to cancel the call (see Try_To_Cancel_Entry_Call for + -- corresponding code in the ATC case). + + Entry_Call.Cancellation_Attempted := True; + + if Self_ID.Pending_ATC_Level >= Entry_Call.Level then + Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; + end if; + + -- The following loop is the same as the loop and exit code + -- from the ordinary Wait_For_Completion. If we get here, we + -- have timed out but we need to keep waiting until the call + -- has actually completed or been cancelled successfully. + + loop + Check_Pending_Actions_For_Entry_Call (Self_ID, Entry_Call); + exit when Entry_Call.State >= Done; + STPO.Sleep (Self_ID, Entry_Caller_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_ID); + + STPO.Unlock (Self_ID); + + if Entry_Call.State = Cancelled then + Initialization.Undefer_Abort_Nestable (Self_ID); + else + -- ???? + + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- Ideally, abort should no longer be deferred at this + -- point, so we should be able to call Check_Exception. + -- The loop below should be considered temporary, + -- to work around the possiblility that abort may be + -- deferred more than one level deep. + + if Entry_Call.Exception_To_Raise /= + Ada.Exceptions.Null_Id then + + while Self_ID.Deferral_Level > 0 loop + Initialization.Undefer_Abort_Nestable (Self_ID); + end loop; + + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end if; + end if; + + return; + end if; + end loop; + + -- This last part is the same as ordinary Wait_For_Completion, + -- and is only executed if the call completed without timing out. + + Self_ID.Common.State := Runnable; + Utilities.Exit_One_ATC_Level (Self_ID); + STPO.Unlock (Self_ID); + + Initialization.Undefer_Abort_Nestable (Self_ID); + + if not Yielded then + STPO.Yield; + end if; + end Wait_For_Completion_With_Timeout; + + -------------------------- + -- Wait_Until_Abortable -- + -------------------------- + + -- Wait to start the abortable part of an async. select statement + -- until the trigger entry call becomes abortable. + + procedure Wait_Until_Abortable + (Self_ID : Task_ID; + Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID.ATC_Nesting_Level > 0); + pragma Assert (Call.Mode = Asynchronous_Call); + + STPO.Write_Lock (Self_ID); + Self_ID.Common.State := Entry_Caller_Sleep; + + loop + Check_Pending_Actions_For_Entry_Call (Self_ID, Call); + exit when Call.State >= Was_Abortable; + STPO.Sleep (Self_ID, Async_Select_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + STPO.Unlock (Self_ID); + end Wait_Until_Abortable; + + -- It might seem that we should be holding the server's lock when + -- we test Call.State above. + + -- In an earlier version, the code above temporarily unlocked the + -- caller and locked the server just for checking Call.State. + -- The unlocking of the caller risked missing a wakeup + -- (an error) and locking the server had no apparent value. + -- We should not need the server's lock, since once Call.State + -- is set to Was_Abortable or beyond, it never goes back below + -- Was_Abortable until this task starts another entry call. + + -- ???? + -- It seems that other calls to Lock_Server may also risk missing + -- wakeups. We need to check that they do not have this problem. + +end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taenca.ads b/gcc/ada/s-taenca.ads new file mode 100644 index 00000000000..e28ff7a3e76 --- /dev/null +++ b/gcc/ada/s-taenca.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- Copyright (C) 1991-1998, 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). -- +-- -- +------------------------------------------------------------------------------ + +package System.Tasking.Entry_Calls is + + procedure Wait_For_Completion + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + -- This procedure suspends the calling task until the specified entry + -- call has either been completed or cancelled. It performs other + -- operations required of suspended tasks, such as performing + -- dynamic priority changes. On exit, the call will not be queued. + -- This waits for calls on task or protected entries. + -- Abortion must be deferred when calling this procedure. + -- Call this only when holding Self_ID locked. + + procedure Wait_For_Completion_With_Timeout + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes); + -- Same as Wait_For_Completion but it wait for a timeout with the value + -- specified in Wakeup_Time as well. + -- Self_ID will be locked by this procedure. + + procedure Wait_Until_Abortable + (Self_ID : Task_ID; + Call : Entry_Call_Link); + -- This procedure suspends the calling task until the specified entry + -- call is queued abortably or completes. + -- Abortion must be deferred when calling this procedure. + + procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean); + pragma Inline (Try_To_Cancel_Entry_Call); + -- Try to cancel async. entry call. + -- Effect includes Abort_To_Level and Wait_For_Completion. + -- Cancelled = True iff the cancelation was successful, i.e., + -- the call was not Done before this call. + -- On return, the call is off-queue and the ATC level is reduced by one. + + procedure Reset_Priority + (Acceptor_Prev_Priority : Rendezvous_Priority; + Acceptor : Task_ID); + pragma Inline (Reset_Priority); + -- Reset the priority of a task completing an accept statement to + -- the value it had before the call. + + procedure Check_Exception + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Exception); + -- Raise any pending exception from the Entry_Call. + -- This should be called at the end of every compiler interface + -- procedure that implements an entry call. + -- In principle, the caller should not be abort-deferred (unless + -- the application program violates the Ada language rules by doing + -- entry calls from within protected operations -- an erroneous practice + -- apparently followed with success by some adventurous GNAT users). + -- Absolutely, the caller should not be holding any locks, or there + -- will be deadlock. + +end System.Tasking.Entry_Calls; diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb new file mode 100644 index 00000000000..13149004416 --- /dev/null +++ b/gcc/ada/s-taprob.adb @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.79 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock + +with Ada.Exceptions; +-- used for Raise_Exception + +package body System.Tasking.Protected_Objects is + + use Ada.Exceptions; + use System.Task_Primitives.Operations; + + ------------------------- + -- Finalize_Protection -- + ------------------------- + + procedure Finalize_Protection (Object : in out Protection) is + begin + Finalize_Lock (Object.L'Unrestricted_Access); + end Finalize_Protection; + + --------------------------- + -- Initialize_Protection -- + --------------------------- + + procedure Initialize_Protection + (Object : Protection_Access; + Ceiling_Priority : Integer) + is + Init_Priority : Integer := Ceiling_Priority; + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + Initialize_Lock (Init_Priority, Object.L'Access); + Object.Ceiling := System.Any_Priority (Init_Priority); + end Initialize_Protection; + + ---------- + -- Lock -- + ---------- + + procedure Lock (Object : Protection_Access) is + Ceiling_Violation : Boolean; + begin + -- The lock is made without defering abortion. + + -- Therefore the abortion has to be deferred before calling this + -- routine. This means that the compiler has to generate a Defer_Abort + -- call before the call to Lock. + + -- The caller is responsible for undeferring abortion, and compiler + -- generated calls must be protected with cleanup handlers to ensure + -- that abortion is undeferred in all cases. + + Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + end if; + end Lock; + + -------------------- + -- Lock_Read_Only -- + -------------------- + + procedure Lock_Read_Only (Object : Protection_Access) is + Ceiling_Violation : Boolean; + begin + Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + end if; + end Lock_Read_Only; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (Object : Protection_Access) is + begin + Unlock (Object.L'Access); + end Unlock; + +end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads new file mode 100644 index 00000000000..b1aafd0e423 --- /dev/null +++ b/gcc/ada/s-taprob.ads @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.35 $ +-- -- +-- Copyright (C) 1992-2001, 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 provides necessary definitions to handle simple (i.e without +-- entries) protected objects. +-- +-- All the routines that handle protected objects with entries have been moved +-- to two children: Entries and Operations. Note that Entries only contains +-- the type declaration and the OO primitives. This is needed to avoid +-- circular dependency. + +-- This package is part of the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +package System.Tasking.Protected_Objects is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + -- + -- protected PO is + -- procedure P; + -- private + -- open : boolean := false; + -- end PO; + -- + -- protected body PO is + -- procedure P is + -- ...variable declarations... + -- begin + -- ...B... + -- end P; + -- end PO; + -- + -- as follows: + -- + -- protected type poT is + -- procedure p; + -- private + -- open : boolean := false; + -- end poT; + -- type poTV is limited record + -- open : boolean := false; + -- _object : aliased protection; + -- end record; + -- procedure poPT__pN (_object : in out poTV); + -- procedure poPT__pP (_object : in out poTV); + -- freeze poTV [ + -- procedure _init_proc (_init : in out poTV) is + -- begin + -- _init.open := false; + -- _init_proc (_init._object); + -- initialize_protection (_init._object'unchecked_access, + -- unspecified_priority); + -- return; + -- end _init_proc; + -- ] + -- po : poT; + -- _init_proc (poTV!(po)); + -- + -- procedure poPT__pN (_object : in out poTV) is + -- poR : protection renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...B... + -- return; + -- end poPT__pN; + -- + -- procedure poPT__pP (_object : in out poTV) is + -- procedure _clean is + -- begin + -- unlock (_object._object'unchecked_access); + -- return; + -- end _clean; + -- begin + -- lock (_object._object'unchecked_access); + -- B2b : begin + -- poPT__pN (_object); + -- at end + -- _clean; + -- end B2b; + -- return; + -- end poPT__pP; + + Null_Protected_Entry : constant := Null_Entry; + + Max_Protected_Entry : constant := Max_Entry; + + type Protected_Entry_Index is new Entry_Index + range Null_Protected_Entry .. Max_Protected_Entry; + + type Barrier_Function_Pointer is access + function + (O : System.Address; + E : Protected_Entry_Index) + return Boolean; + -- Pointer to a function which evaluates the barrier of a protected + -- entry body. O is a pointer to the compiler-generated record + -- representing the protected object, and E is the index of the + -- entry serviced by the body. + + type Entry_Action_Pointer is access + procedure + (O : System.Address; + P : System.Address; + E : Protected_Entry_Index); + -- Pointer to a procedure which executes the sequence of statements + -- of a protected entry body. O is a pointer to the compiler-generated + -- record representing the protected object, P is a pointer to the + -- record of entry parameters, and E is the index of the + -- entry serviced by the body. + + type Entry_Body is record + Barrier : Barrier_Function_Pointer; + Action : Entry_Action_Pointer; + end record; + -- The compiler-generated code passes objects of this type to the GNARL + -- to allow it to access the executable code of an entry body. + + type Entry_Body_Access is access all Entry_Body; + + type Protection is limited private; + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + -- Note that there are now 2 Protection types. One for the simple + -- case (no entries) and one for the general case that needs the whole + -- Finalization mechanism. + -- This split helps in the case of restricted run time where we want to + -- minimize the size of the code. + + type Protection_Access is access all Protection; + + Null_PO : constant Protection_Access := null; + + procedure Initialize_Protection + (Object : Protection_Access; + Ceiling_Priority : Integer); + -- Initialize the Object parameter so that it can be used by the runtime + -- to keep track of the runtime state of a protected object. + + procedure Lock (Object : Protection_Access); + -- Lock a protected object for write access. Upon return, the caller + -- owns the lock to this object, and no other call to Lock or + -- Lock_Read_Only with the same argument will return until the + -- corresponding call to Unlock has been made by the caller. + + procedure Lock_Read_Only (Object : Protection_Access); + -- Lock a protected object for read access. Upon return, the caller + -- owns the lock for read access, and no other calls to Lock with the + -- same argument will return until the corresponding call to Unlock + -- has been made by the caller. Other calls to Lock_Read_Only may (but + -- need not) return before the call to Unlock, and the corresponding + -- callers will also own the lock for read access. + -- + -- Note: we are not currently using this interface, it is provided + -- for possible future use. At the current time, everyone uses Lock + -- for both read and write locks. + + procedure Unlock (Object : Protection_Access); + -- Relinquish ownership of the lock for the object represented by + -- the Object parameter. If this ownership was for write access, or + -- if it was for read access where there are no other read access + -- locks outstanding, one (or more, in the case of Lock_Read_Only) + -- of the tasks waiting on this lock (if any) will be given the + -- lock and allowed to return from the Lock or Lock_Read_Only call. + +private + type Protection is record + L : aliased Task_Primitives.Lock; + Ceiling : System.Any_Priority; + end record; + pragma Volatile (Protection); + for Protection'Alignment use Standard'Maximum_Alignment; + -- Needed so that we can uncheck convert a Protection_Access to a + -- Protection_Entries_Access. + + procedure Finalize_Protection (Object : in out Protection); + -- Clean up a Protection object; in particular, finalize the associated + -- Lock object. The compiler generates automatically calls to this + -- procedure + +end System.Tasking.Protected_Objects; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads new file mode 100644 index 00000000000..19f035c4b9a --- /dev/null +++ b/gcc/ada/s-taprop.ads @@ -0,0 +1,476 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S .O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.40 $ +-- -- +-- Copyright (C) 1992-2001, 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 contains all the GNULL primitives that interface directly +-- with the underlying OS. + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Task_ID + +with System.OS_Interface; +-- used for Thread_Id + +package System.Task_Primitives.Operations is + + pragma Elaborate_Body; + package ST renames System.Tasking; + package OSI renames System.OS_Interface; + + procedure Initialize (Environment_Task : ST.Task_ID); + pragma Inline (Initialize); + -- This must be called once, before any other subprograms of this + -- package are called. + + procedure Create_Task + (T : ST.Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean); + pragma Inline (Create_Task); + -- Create a new low-level task with ST.Task_ID T and place other needed + -- information in the ATCB. + -- + -- A new thread of control is created, with a stack of at least Stack_Size + -- storage units, and the procedure Wrapper is called by this new thread + -- of control. If Stack_Size = Unspecified_Storage_Size, choose a default + -- stack size; this may be effectively "unbounded" on some systems. + -- + -- The newly created low-level task is associated with the ST.Task_ID T + -- such that any subsequent call to Self from within the context of the + -- low-level task returns T. + -- + -- The caller is responsible for ensuring that the storage of the Ada + -- task control block object pointed to by T persists for the lifetime + -- of the new task. + -- + -- Succeeded is set to true unless creation of the task failed, + -- as it may if there are insufficient resources to create another task. + + procedure Enter_Task (Self_ID : ST.Task_ID); + pragma Inline (Enter_Task); + -- Initialize data structures specific to the calling task. + -- Self must be the ID of the calling task. + -- It must be called (once) by the task immediately after creation, + -- while abortion is still deferred. + -- The effects of other operations defined below are not defined + -- unless the caller has previously called Initialize_Task. + + procedure Exit_Task; + pragma Inline (Exit_Task); + -- Destroy the thread of control. + -- Self must be the ID of the calling task. + -- The effects of further calls to operations defined below + -- on the task are undefined thereafter. + + function New_ATCB (Entry_Num : ST.Task_Entry_Index) return ST.Task_ID; + pragma Inline (New_ATCB); + -- Allocate a new ATCB with the specified number of entries. + + procedure Initialize_TCB (Self_ID : ST.Task_ID; Succeeded : out Boolean); + pragma Inline (Initialize_TCB); + -- Initialize all fields of the TCB + + procedure Finalize_TCB (T : ST.Task_ID); + pragma Inline (Finalize_TCB); + -- Finalizes Private_Data of ATCB, and then deallocates it. + -- This is also responsible for recovering any storage or other resources + -- that were allocated by Create_Task (the one in this package). + -- This should only be called from Free_Task. + -- After it is called there should be no further + -- reference to the ATCB that corresponds to T. + + procedure Abort_Task (T : ST.Task_ID); + pragma Inline (Abort_Task); + -- Abort the task specified by T (the target task). This causes + -- the target task to asynchronously raise Abort_Signal if + -- abort is not deferred, or if it is blocked on an interruptible + -- system call. + -- + -- precondition: + -- the calling task is holding T's lock and has abort deferred + -- + -- postcondition: + -- the calling task is holding T's lock and has abort deferred. + + -- ??? modify GNARL to skip wakeup and always call Abort_Task + + function Self return ST.Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + type Lock_Level is + (PO_Level, + Global_Task_Level, + All_Attrs_Level, + All_Tasks_Level, + Interrupts_Level, + ATCB_Level); + -- Type used to describe kind of lock for second form of Initialize_Lock + -- call specified below. + -- See locking rules in System.Tasking (spec) for more details. + + procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock); + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level); + pragma Inline (Initialize_Lock); + -- Initialize a lock object. + -- + -- For Lock, Prio is the ceiling priority associated with the lock. + -- For RTS_Lock, the ceiling is implicitly Priority'Last. + -- + -- If the underlying system does not support priority ceiling + -- locking, the Prio parameter is ignored. + -- + -- The effect of either initialize operation is undefined unless L + -- is a lock object that has not been initialized, or which has been + -- finalized since it was last initialized. + -- + -- The effects of the other operations on lock objects + -- are undefined unless the lock object has been initialized + -- and has not since been finalized. + -- + -- Initialization of the per-task lock is implicit in Create_Task. + -- + -- These operations raise Storage_Error if a lack of storage is detected. + + procedure Finalize_Lock (L : access Lock); + procedure Finalize_Lock (L : access RTS_Lock); + pragma Inline (Finalize_Lock); + -- Finalize a lock object, freeing any resources allocated by the + -- corresponding Initialize_Lock operation. + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean); + procedure Write_Lock (L : access RTS_Lock); + procedure Write_Lock (T : ST.Task_ID); + pragma Inline (Write_Lock); + -- Lock a lock object for write access. After this operation returns, + -- the calling task holds write permission for the lock object. No other + -- Write_Lock or Read_Lock operation on the same lock object will return + -- until this task executes an Unlock operation on the same object. The + -- effect is undefined if the calling task already holds read or write + -- permission for the lock object L. + -- + -- For the operation on Lock, Ceiling_Violation is set to true iff the + -- operation failed, which will happen if there is a priority ceiling + -- violation. + -- + -- For the operation on ST.Task_ID, the lock is the special lock object + -- associated with that task's ATCB. This lock has effective ceiling + -- priority high enough that it is safe to call by a task with any + -- priority in the range System.Priority. It is implicitly initialized + -- by task creation. The effect is undefined if the calling task already + -- holds T's lock, or has interrupt-level priority. Finalization of the + -- per-task lock is implicit in Exit_Task. + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean); + pragma Inline (Read_Lock); + -- Lock a lock object for read access. After this operation returns, + -- the calling task has non-exclusive read permission for the logical + -- resources that are protected by the lock. No other Write_Lock operation + -- on the same object will return until this task and any other tasks with + -- read permission for this lock have executed Unlock operation(s) on the + -- lock object. A Read_Lock for a lock object may return immediately while + -- there are tasks holding read permission, provided there are no tasks + -- holding write permission for the object. The effect is undefined if + -- the calling task already holds read or write permission for L. + -- + -- Alternatively: An implementation may treat Read_Lock identically to + -- Write_Lock. This simplifies the implementation, but reduces the level + -- of concurrency that can be achieved. + -- + -- Note that Read_Lock is not defined for RT_Lock and ST.Task_ID. + -- That is because (1) so far Read_Lock has always been implemented + -- the same as Write_Lock, (2) most lock usage inside the RTS involves + -- potential write access, and (3) implementations of priority ceiling + -- locking that make a reader-writer distinction have higher overhead. + + procedure Unlock (L : access Lock); + procedure Unlock (L : access RTS_Lock); + procedure Unlock (T : ST.Task_ID); + pragma Inline (Unlock); + -- Unlock a locked lock object. + -- + -- The effect is undefined unless the calling task holds read or write + -- permission for the lock L, and L is the lock object most recently + -- locked by the calling task for which the calling task still holds + -- read or write permission. (That is, matching pairs of Lock and Unlock + -- operations on each lock object must be properly nested.) + + -- Note that Write_Lock for RTS_Lock does not have an out-parameter. + -- RTS_Locks are used in situations where we have not made provision + -- for recovery from ceiling violations. We do not expect them to + -- occur inside the runtime system, because all RTS locks have ceiling + -- Priority'Last. + + -- There is one way there can be a ceiling violation. + -- That is if the runtime system is called from a task that is + -- executing in the Interrupt_Priority range. + + -- It is not clear what to do about ceiling violations due + -- to RTS calls done at interrupt priority. In general, it + -- is not acceptable to give all RTS locks interrupt priority, + -- since that whould give terrible performance on systems where + -- this has the effect of masking hardware interrupts, though we + -- could get away with allowing Interrupt_Priority'last where we + -- are layered on an OS that does not allow us to mask interrupts. + -- Ideally, we would like to raise Program_Error back at the + -- original point of the RTS call, but this would require a lot of + -- detailed analysis and recoding, with almost certain performance + -- penalties. + + -- For POSIX systems, we considered just skipping setting a + -- priority ceiling on RTS locks. This would mean there is no + -- ceiling violation, but we would end up with priority inversions + -- inside the runtime system, resulting in failure to satisfy the + -- Ada priority rules, and possible missed validation tests. + -- This could be compensated-for by explicit priority-change calls + -- to raise the caller to Priority'Last whenever it first enters + -- the runtime system, but the expected overhead seems high, though + -- it might be lower than using locks with ceilings if the underlying + -- implementation of ceiling locks is an inefficient one. + + -- This issue should be reconsidered whenever we get around to + -- checking for calls to potentially blocking operations from + -- within protected operations. If we check for such calls and + -- catch them on entry to the OS, it may be that we can eliminate + -- the possibility of ceiling violations inside the RTS. For this + -- to work, we would have to forbid explicitly setting the priority + -- of a task to anything in the Interrupt_Priority range, at least. + -- We would also have to check that there are no RTS-lock operations + -- done inside any operations that are not treated as potentially + -- blocking. + + -- The latter approach seems to be the best, i.e. to check on entry + -- to RTS calls that may need to use locks that the priority is not + -- in the interrupt range. If there are RTS operations that NEED to + -- be called from interrupt handlers, those few RTS locks should then + -- be converted to PO-type locks, with ceiling Interrupt_Priority'Last. + + -- For now, we will just shut down the system if there is a + -- ceiling violation. + + procedure Yield (Do_Yield : Boolean := True); + pragma Inline (Yield); + -- Yield the processor. Add the calling task to the tail of the + -- ready queue for its active_priority. + -- The Do_Yield argument is only used in some very rare cases very + -- a yield should have an effect on a specific target and not on regular + -- ones. + + procedure Set_Priority + (T : ST.Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False); + pragma Inline (Set_Priority); + -- Set the priority of the task specified by T to T.Current_Priority. + -- The priority set is what would correspond to the Ada concept of + -- "base priority" in the terms of the lower layer system, but + -- the operation may be used by the upper layer to implement + -- changes in "active priority" that are not due to lock effects. + -- The effect should be consistent with the Ada Reference Manual. + -- In particular, when a task lowers its priority due to the loss of + -- inherited priority, it goes at the head of the queue for its new + -- priority (RM D.2.2 par 9). + -- Loss_Of_Inheritance helps the underlying implementation to do it + -- right when the OS doesn't. + + function Get_Priority (T : ST.Task_ID) return System.Any_Priority; + pragma Inline (Get_Priority); + -- Returns the priority last set by Set_Priority for this task. + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Jan 1, 1970. + -- This clock implementation is immune to the system's clock changes. + + function RT_Resolution return Duration; + pragma Inline (RT_Resolution); + -- Returns the resolution of the underlying clock used to implement + -- RT_Clock. + + ------------------ + -- Extensions -- + ------------------ + + -- Whoever calls either of the Sleep routines is responsible + -- for checking for pending aborts before the call. + -- Pending priority changes are handled internally. + + procedure Sleep + (Self_ID : ST.Task_ID; + Reason : System.Tasking.Task_States); + pragma Inline (Sleep); + -- Wait until the current task, T, is signaled to wake up. + -- + -- precondition: + -- The calling task is holding its own ATCB lock + -- and has abort deferred + -- + -- postcondition: + -- The calling task is holding its own ATCB lock + -- and has abort deferred. + + -- The effect is to atomically unlock T's lock and wait, so that another + -- task that is able to lock T's lock can be assured that the wait has + -- actually commenced, and that a Wakeup operation will cause the waiting + -- task to become ready for execution once again. When Sleep returns, + -- the waiting task will again hold its own ATCB lock. The waiting task + -- may become ready for execution at any time (that is, spurious wakeups + -- are permitted), but it will definitely become ready for execution when + -- a Wakeup operation is performed for the same task. + + procedure Timed_Sleep + (Self_ID : ST.Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean); + -- Combination of Sleep (above) and Timed_Delay + + procedure Timed_Delay + (Self_ID : ST.Task_ID; + Time : Duration; + Mode : ST.Delay_Modes); + -- Implements the semantics of the delay statement. It is assumed that + -- the caller is not abort-deferred and does not hold any locks. + + procedure Wakeup + (T : ST.Task_ID; + Reason : System.Tasking.Task_States); + pragma Inline (Wakeup); + -- Wake up task T if it is waiting on a Sleep call (of ordinary + -- or timed variety), making it ready for execution once again. + -- If the task T is not waiting on a Sleep, the operation has no effect. + + function Environment_Task return ST.Task_ID; + pragma Inline (Environment_Task); + -- returns the task ID of the environment task + -- Consider putting this into a variable visible directly + -- by the rest of the runtime system. ??? + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id; + -- returns the thread id of the specified task. + + -------------------- + -- Stack Checking -- + -------------------- + + -- Stack checking in GNAT is done using the concept of stack probes. A + -- stack probe is an operation that will generate a storage error if + -- an insufficient amount of stack space remains in the current task. + + -- The exact mechanism for a stack probe is target dependent. Typical + -- possibilities are to use a load from a non-existent page, a store + -- to a read-only page, or a comparison with some stack limit constant. + -- Where possible we prefer to use a trap on a bad page access, since + -- this has less overhead. The generation of stack probes is either + -- automatic if the ABI requires it (as on for example DEC Unix), or + -- is controlled by the gcc parameter -fstack-check. + + -- When we are using bad-page accesses, we need a bad page, called a + -- guard page, at the end of each task stack. On some systems, this + -- is provided automatically, but on other systems, we need to create + -- the guard page ourselves, and the procedure Stack_Guard is provided + -- for this purpose. + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean); + -- Ensure guard page is set if one is needed and the underlying thread + -- system does not provide it. The procedure is as follows: + -- + -- 1. When we create a task adjust its size so a guard page can + -- safely be set at the bottom of the stack + -- + -- 2. When the thread is created (and its stack allocated by the + -- underlying thread system), get the stack base (and size, depending + -- how the stack is growing), and create the guard page taking care of + -- page boundaries issues. + -- + -- 3. When the task is destroyed, remove the guard page. + -- + -- If On is true then protect the stack bottom (i.e make it read only) + -- else unprotect it (i.e. On is True for the call when creating a task, + -- and False when a task is destroyed). + -- + -- The call to Stack_Guard has no effect if guard pages are not used on + -- the target, or if guard pages are automatically provided by the system. + + ----------------------------------------- + -- Runtime System Debugging Interfaces -- + ----------------------------------------- + + -- These interfaces have been added to assist in debugging the + -- tasking runtime system. + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean; + pragma Inline (Check_Exit); + -- Check that the current task is holding only Global_Task_Lock. + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean; + pragma Inline (Check_No_Locks); + -- Check that current task is holding no locks. + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : OSI.Thread_Id) return Boolean; + -- Suspend a specific task when the underlying thread library provides + -- such functionality, unless the thread associated with T is + -- Thread_Self. + -- Such functionnality is needed by gdb on some targets (e.g VxWorks) + -- Return True is the operation is successful + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : OSI.Thread_Id) return Boolean; + -- Resume a specific task when the underlying thread library provides + -- such functionality, unless the thread associated with T is + -- Thread_Self. + -- Such functionnality is needed by gdb on some targets (e.g VxWorks) + -- Return True is the operation is successful + + procedure Lock_All_Tasks_List; + procedure Unlock_All_Tasks_List; + -- Lock/Unlock the All_Tasks_L lock which protects + -- System.Initialization.All_Tasks_List and Known_Tasks + -- ??? These routines were previousely in System.Tasking.Initialization + -- but were moved here to avoid dependency problems. That would be + -- nice to look at it some day and put it back in Initialization. + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb new file mode 100644 index 00000000000..a6cf274c8ef --- /dev/null +++ b/gcc/ada/s-tarest.adb @@ -0,0 +1,548 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram alpha order check, since we group soft link +-- bodies and also separate off subprograms for restricted GNARLI. + +-- This is a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Parameters; +-- used for Size_Type + +with System.Task_Info; +-- used for Task_Info_Type +-- Task_Image_Type + +with System.Task_Primitives.Operations; +-- used for Enter_Task +-- Write_Lock +-- Unlock +-- Wakeup +-- Get_Priority + +with System.Soft_Links; +-- used for the non-tasking routines (*_NT) that refer to global data. +-- They are needed here before the tasking run time has been elaborated. +-- used for Create_TSD +-- This package also provides initialization routines for task specific data. +-- The GNARL must call these to be sure that all non-tasking +-- Ada constructs will work. + +with System.Secondary_Stack; +-- used for SS_Init; + +with System.Storage_Elements; +-- used for Storage_Array; + +package body System.Tasking.Restricted.Stages is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package SSE renames System.Storage_Elements; + package SST renames System.Secondary_Stack; + + use System.Task_Primitives; + use System.Task_Primitives.Operations; + use System.Task_Info; + + Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion + -- from all other tasks. It is only used by Task_Lock and Task_Unlock. + + ----------------------------------------------------------------- + -- Tasking versions of services needed by non-tasking programs -- + ----------------------------------------------------------------- + + procedure Task_Lock; + -- Locks out other tasks. Preceding a section of code by Task_Lock and + -- following it by Task_Unlock creates a critical region. This is used + -- for ensuring that a region of non-tasking code (such as code used to + -- allocate memory) is tasking safe. Note that it is valid for calls to + -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. + -- only the corresponding outer level Task_Unlock will actually unlock. + + procedure Task_Unlock; + -- Releases lock previously set by call to Task_Lock. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + + function Get_Jmpbuf_Address return Address; + procedure Set_Jmpbuf_Address (Addr : Address); + + function Get_Sec_Stack_Addr return Address; + procedure Set_Sec_Stack_Addr (Addr : Address); + + function Get_Machine_State_Addr return Address; + procedure Set_Machine_State_Addr (Addr : Address); + + function Get_Current_Excep return SSL.EOA; + + procedure Timed_Delay_T (Time : Duration; Mode : Integer); + + ------------------------ + -- Local Subprograms -- + ------------------------ + + procedure Task_Wrapper (Self_ID : Task_ID); + -- This is the procedure that is called by the GNULL from the + -- new context when a task is created. It waits for activation + -- and then calls the task body procedure. When the task body + -- procedure completes, it terminates the task. + + procedure Terminate_Task (Self_ID : Task_ID); + -- Terminate the calling task. + -- This should only be called by the Task_Wrapper procedure. + + procedure Init_RTS; + -- This procedure performs the initialization of the GNARL. + -- It consists of initializing the environment task, global locks, and + -- installing tasking versions of certain operations used by the compiler. + -- Init_RTS is called during elaboration. + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock is + begin + STPO.Write_Lock (Global_Task_Lock'Access); + end Task_Lock; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock is + begin + STPO.Unlock (Global_Task_Lock'Access); + end Task_Unlock; + + ---------------------- + -- Soft-Link Bodies -- + ---------------------- + + function Get_Current_Excep return SSL.EOA is + begin + return STPO.Self.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + function Get_Jmpbuf_Address return Address is + begin + return STPO.Self.Common.Compiler_Data.Jmpbuf_Address; + end Get_Jmpbuf_Address; + + function Get_Machine_State_Addr return Address is + begin + return STPO.Self.Common.Compiler_Data.Machine_State_Addr; + end Get_Machine_State_Addr; + + function Get_Sec_Stack_Addr return Address is + begin + return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr; + end Get_Sec_Stack_Addr; + + procedure Set_Jmpbuf_Address (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address; + + procedure Set_Machine_State_Addr (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr; + end Set_Machine_State_Addr; + + procedure Set_Sec_Stack_Addr (Addr : Address) is + begin + STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr; + + ------------------ + -- Task_Wrapper -- + ------------------ + + -- The task wrapper is a procedure that is called first for each task + -- task body, and which in turn calls the compiler-generated task body + -- procedure. The wrapper's main job is to do initialization for the task. + + -- The variable ID in the task wrapper is used to implement the Self + -- function on targets where there is a fast way to find the stack base + -- of the current thread, since it should be at a fixed offset from the + -- stack base. + + procedure Task_Wrapper (Self_ID : Task_ID) is + ID : Task_ID := Self_ID; + pragma Volatile (ID); + + -- Do not delete this variable. + -- In some targets, we need this variable to implement a fast Self. + + use type System.Parameters.Size_Type; + use type SSE.Storage_Offset; + + Secondary_Stack : aliased SSE.Storage_Array + (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * + SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100); + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + + begin + if not Parameters.Sec_Stack_Dynamic then + Self_ID.Common.Compiler_Data.Sec_Stack_Addr := + Secondary_Stack'Address; + SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); + end if; + + -- Initialize low-level TCB components, that + -- cannot be initialized by the creator. + + Enter_Task (Self_ID); + + -- Call the task body procedure. + + begin + -- We are separating the following portion of the code in order to + -- place the exception handlers in a different block. + -- In this way we do not call Set_Jmpbuf_Address (which needs + -- Self) before we set Self in Enter_Task. + -- Note that in the case of Ravenscar HI-E where there are no + -- exception handlers, the exception handler is suppressed. + + -- Call the task body procedure. + + Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); + Terminate_Task (Self_ID); + + exception -- not needed in no exc mode + when others => -- not needed in no exc mode + Terminate_Task (Self_ID); -- not needed in no exc mode + end; + end Task_Wrapper; + + ------------------- + -- Timed_Delay_T -- + ------------------- + + procedure Timed_Delay_T (Time : Duration; Mode : Integer) is + begin + STPO.Timed_Delay (STPO.Self, Time, Mode); + end Timed_Delay_T; + + ----------------------- + -- Restricted GNARLI -- + ----------------------- + + ------------------------------- + -- Activate_Restricted_Tasks -- + ------------------------------- + + -- Note that locks of activator and activated task are both locked + -- here. This is necessary because C.State and Self.Wait_Count + -- have to be synchronized. This is safe from deadlock because + -- the activator is always created before the activated task. + -- That satisfies our in-order-of-creation ATCB locking policy. + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access) + is + Self_ID : constant Task_ID := STPO.Self; + C : Task_ID; + Activate_Prio : System.Any_Priority; + Success : Boolean; + + begin + pragma Assert (Self_ID = Environment_Task); + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Lock self, to prevent activated tasks + -- from racing ahead before we finish activating the chain. + + Write_Lock (Self_ID); + + -- Activate all the tasks in the chain. + -- Creation of the thread of control was deferred until + -- activation. So create it now. + + C := Chain_Access.T_ID; + + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + Write_Lock (C); + + if C.Common.Base_Priority < Get_Priority (Self_ID) then + Activate_Prio := Get_Priority (Self_ID); + else + Activate_Prio := C.Common.Base_Priority; + end if; + + STPO.Create_Task + (C, Task_Wrapper'Address, + Parameters.Size_Type + (C.Common.Compiler_Data.Pri_Stack_Info.Size), + Activate_Prio, Success); + + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + + if Success then + C.Common.State := Runnable; + else + raise Program_Error; + end if; + + Unlock (C); + end if; + + C := C.Common.Activation_Link; + end loop; + + Self_ID.Common.State := Activator_Sleep; + + -- Wait for the activated tasks to complete activation. + -- It is unsafe to abort any of these tasks until the count goes to + -- zero. + + loop + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Activator_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + -- Remove the tasks from the chain. + + Chain_Access.T_ID := null; + end Activate_Restricted_Tasks; + + ------------------------------------ + -- Complete_Restricted_Activation -- + ------------------------------------ + + -- As in several other places, the locks of the activator and activated + -- task are both locked here. This follows our deadlock prevention lock + -- ordering policy, since the activated task must be created after the + -- activator. + + procedure Complete_Restricted_Activation is + Self_ID : constant Task_ID := STPO.Self; + Activator : constant Task_ID := Self_ID.Common.Activator; + + begin + Write_Lock (Activator); + Write_Lock (Self_ID); + + -- Remove dangling reference to Activator, + -- since a task may outlive its activator. + + Self_ID.Common.Activator := null; + + -- Wake up the activator, if it is waiting for a chain + -- of tasks to activate, and we are the last in the chain + -- to complete activation + + if Activator.Common.State = Activator_Sleep then + Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; + + if Activator.Common.Wait_Count = 0 then + Wakeup (Activator, Activator_Sleep); + end if; + end if; + + Unlock (Self_ID); + Unlock (Activator); + + -- After the activation, active priority should be the same + -- as base priority. We must unlock the Activator first, + -- though, since it should not wait if we have lower priority. + + if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + end Complete_Restricted_Activation; + + ------------------------------ + -- Complete_Restricted_Task -- + ------------------------------ + + procedure Complete_Restricted_Task is + begin + STPO.Self.Common.State := Terminated; + end Complete_Restricted_Task; + + ---------------------------- + -- Create_Restricted_Task -- + ---------------------------- + + procedure Create_Restricted_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : System.Task_Info.Task_Image_Type; + Created_Task : out Task_ID) + is + T : Task_ID; + Self_ID : constant Task_ID := STPO.Self; + Base_Priority : System.Any_Priority; + Success : Boolean; + + begin + if Priority = Unspecified_Priority then + Base_Priority := Self_ID.Common.Base_Priority; + else + Base_Priority := System.Any_Priority (Priority); + end if; + + T := New_ATCB (0); + Write_Lock (Self_ID); + + -- With no task hierarchy, the parent of all non-Environment tasks that + -- are created must be the Environment task + + Initialize_ATCB + (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, + Task_Info, Size, T, Success); + + -- If we do our job right then there should never be any failures, + -- which was probably said about the Titanic; so just to be safe, + -- let's retain this code for now + + if not Success then + Unlock (Self_ID); + raise Program_Error; + end if; + + T.Entry_Calls (1).Self := T; + T.Common.Task_Image := Task_Image; + Unlock (Self_ID); + + -- Create TSD as early as possible in the creation of a task, since it + -- may be used by the operation of Ada code within the task. + + SSL.Create_TSD (T.Common.Compiler_Data); + T.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := T; + Created_Task := T; + end Create_Restricted_Task; + + --------------------------- + -- Finalize_Global_Tasks -- + --------------------------- + + -- This is needed to support the compiler interface; it will only be called + -- by the Environment task. Instead, it will cause the Environment to block + -- forever, since none of the dependent tasks are expected to terminate + + procedure Finalize_Global_Tasks is + Self_ID : constant Task_ID := STPO.Self; + begin + pragma Assert (Self_ID = STPO.Environment_Task); + + Write_Lock (Self_ID); + Sleep (Self_ID, Master_Completion_Sleep); + Unlock (Self_ID); + + -- Should never return from Master Completion Sleep + + raise Program_Error; + end Finalize_Global_Tasks; + + --------------------------- + -- Restricted_Terminated -- + --------------------------- + + function Restricted_Terminated (T : Task_ID) return Boolean is + begin + return T.Common.State = Terminated; + end Restricted_Terminated; + + -------------------- + -- Terminate_Task -- + -------------------- + + procedure Terminate_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.State := Terminated; + end Terminate_Task; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + begin + -- Initialize lock used to implement mutual exclusion between all tasks + + STPO.Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); + + -- Notify that the tasking run time has been elaborated so that + -- the tasking version of the soft links can be used. + + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; + SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; + SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; + SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access; + SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; + SSL.Timed_Delay := Timed_Delay_T'Access; + SSL.Adafinal := Finalize_Global_Tasks'Access; + + -- No need to create a new Secondary Stack, since we will use the + -- default one created in s-secsta.adb + + SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); + SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); + SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT); + end Init_RTS; + +begin + Init_RTS; +end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/s-tarest.ads b/gcc/ada/s-tarest.ads new file mode 100644 index 00000000000..7846fbc3233 --- /dev/null +++ b/gcc/ada/s-tarest.ads @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D . S T A G E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This is a simplified version of the System.Tasking.Stages package, +-- intended to be used in a restricted run time. + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +-- The restricted GNARLI is also composed of System.Protected_Objects and +-- System.Protected_Objects.Single_Entry + +with System.Task_Info; +-- used for Task_Info_Type + +with System.Parameters; +-- used for Size_Type + +package System.Tasking.Restricted.Stages is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + -- + -- task type T (Discr : Integer); + -- + -- task body T is + -- ...declarations, possibly some controlled... + -- begin + -- ...B...; + -- end T; + -- + -- T1 : T (1); + -- + -- as follows: + -- + -- task type t (discr : integer); + -- tE : aliased boolean := false; + -- tZ : size_type := unspecified_size; + -- type tV (discr : integer) is limited record + -- _task_id : task_id; + -- end record; + -- procedure tB (_task : access tV); + -- freeze tV [ + -- procedure _init_proc (_init : in out tV; _master : master_id; + -- _chain : in out activation_chain; _task_id : in task_image_type; + -- discr : integer) is + -- begin + -- _init.discr := discr; + -- _init._task_id := null; + -- create_restricted_task (unspecified_priority, tZ, + -- unspecified_task_info, task_procedure_access!(tB'address), + -- _init'address, tE'unchecked_access, _chain, _task_id, _init. + -- _task_id); + -- return; + -- end _init_proc; + -- ] + -- + -- _chain : aliased activation_chain; + -- _init_proc (_chain); + -- + -- procedure tB (_task : access tV) is + -- discr : integer renames _task.discr; + -- + -- procedure _clean is + -- begin + -- complete_restricted_task; + -- finalize_list (F14b); + -- return; + -- end _clean; + -- begin + -- ...declarations... + -- complete_restricted_activation; + -- ...B...; + -- return; + -- at end + -- _clean; + -- end tB; + -- + -- tE := true; + -- t1 : t (1); + -- t1I : task_image_type := new string'"t1"; + -- _init_proc (t1, 3, _chain, t1I, 1); + -- + -- activate_restricted_tasks (_chain'unchecked_access); + + procedure Create_Restricted_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : System.Task_Info.Task_Image_Type; + Created_Task : out Task_ID); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task. + -- + -- Priority is the task's priority (assumed to be in the + -- System.Any_Priority'Range) + -- Size is the stack size of the task to create + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- State is the compiler generated task's procedure body + -- Discriminants is a pointer to a limited record whose discriminants + -- are those of the task to create. This parameter should be passed as + -- the single argument to State. + -- Elaborated is a pointer to a Boolean that must be set to true on exit + -- if the task could be sucessfully elaborated. + -- Chain is a linked list of task that needs to be created. On exit, + -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID + -- will be Created_Task (e.g the created task will be linked at the front + -- of Chain). + -- Task_Image is a pointer to a string created by the compiler that the + -- run time can store to ease the debugging and the + -- Ada.Task_Identification facility. + -- Created_Task is the resulting task. + -- + -- This procedure can raise Storage_Error if the task creation failed. + + procedure Activate_Restricted_Tasks + (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the creator of a chain of one or more new tasks, + -- to activate them. The chain is a linked list that up to this point is + -- only known to the task that created them, though the individual tasks + -- are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a stack). Another + -- version of this procedure had code to reverse the chain, so as to + -- activate the tasks in the order of declaration. This might be nice, but + -- it is not needed if priority-based scheduling is supported, since all + -- the activated tasks synchronize on the activators lock before they + -- start activating and so they should start activating in priority order. + + procedure Complete_Restricted_Activation; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from the task body at the end of + -- the elaboration code for its declarative part. + -- Decrement the count of tasks to be activated by the activator and + -- wake it up so it can check to see if all tasks have been activated. + -- Except for the environment task, which should never call this procedure, + -- T.Activator should only be null iff T has completed activation. + + procedure Complete_Restricted_Task; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from an implicit at-end handler + -- associated with the task body, when it completes. + -- From this point, the current task will become not callable. + -- If the current task have not completed activation, this should be done + -- now in order to wake up the activator (the environment task). + + function Restricted_Terminated (T : Task_ID) return Boolean; + -- Compiler interface only. Do not call from within the RTS. + -- This is called by the compiler to implement the 'Terminated attribute. + -- + -- source code: + -- T1'Terminated + -- + -- code expansion: + -- restricted_terminated (t1._task_id) + + procedure Finalize_Global_Tasks; + -- This is needed to support the compiler interface; it will only be called + -- by the Environment task in the binder generated file (by adafinal). + -- Instead, it will cause the Environment to block forever, since none of + -- the dependent tasks are expected to terminate + +end System.Tasking.Restricted.Stages; diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb new file mode 100644 index 00000000000..83e2efcc645 --- /dev/null +++ b/gcc/ada/s-tasdeb.adb @@ -0,0 +1,704 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.23 $ +-- -- +-- Copyright (C) 1997-2001 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 all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode (1.13 and higher) + +-- Note : This file *must* be compiled with debugging information + +-- Do not add any dependency to GNARL packages since this package is used +-- in both normal and resticted (ravenscar) environments. + +with System.Task_Info, + System.Task_Primitives.Operations, + Unchecked_Conversion; + +package body System.Tasking.Debug is + + use Interfaces.C; + + package STPO renames System.Task_Primitives.Operations; + + type Integer_Address is mod 2 ** Standard'Address_Size; + type Integer_Address_Ptr is access all Integer_Address; + + function "+" is new + Unchecked_Conversion (System.Address, Integer_Address_Ptr); + + function "+" is new + Unchecked_Conversion (Task_ID, Integer_Address); + + Hex_Address_Width : constant := (Standard'Address_Size / 4); + + Zero_Pos : constant := Character'Pos ('0'); + + Hex_Digits : constant array (0 .. Integer_Address'(15)) of Character := + "0123456789abcdef"; + + subtype Buf_Range is Integer range 1 .. 80; + type Buf_Array is array (Buf_Range) of aliased Character; + + type Buffer is record + Next : Buf_Range := Buf_Range'First; + Chars : Buf_Array := (Buf_Range => ' '); + end record; + + type Buffer_Ptr is access all Buffer; + + type Trace_Flag_Set is array (Character) of Boolean; + + Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Put + (T : ST.Task_ID; + Width : Integer; + Buffer : Buffer_Ptr); + -- Put TCB pointer T, (coded in hexadecimal) into Buffer + -- right-justififed in Width characters. + + procedure Put + (N : Integer_Address; + Width : Integer; + Buffer : Buffer_Ptr); + -- Put N (coded in decimal) into Buf right-justified in Width + -- characters starting at Buf (Next). + + procedure Put + (S : String; + Width : Integer; + Buffer : Buffer_Ptr); + -- Put string S into Buf left-justified in Width characters + -- starting with space in Buf (Next), truncated as necessary. + + procedure Put + (C : Character; + Buffer : Buffer_Ptr); + -- Put character C into Buf, left-justified, starting at Buf (Next) + + procedure Space (Buffer : Buffer_Ptr); + -- Increment Next, resulting in a space + + procedure Space + (N : Integer; + Buffer : Buffer_Ptr); + -- Increment Next by N, resulting in N spaces + + procedure Clear (Buffer : Buffer_Ptr); + -- Clear Buf and reset Next to 1 + + procedure Write_Buf (Buffer : Buffer_Ptr); + -- Write contents of Buf (1 .. Next) to standard output + + ----------- + -- Clear -- + ----------- + + procedure Clear (Buffer : Buffer_Ptr) is + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + + begin + Buf := (Buf_Range => ' '); + Next := 1; + end Clear; + + ----------- + -- Image -- + ----------- + + function Image (T : ST.Task_ID) return String is + Buf : aliased Buffer; + Result : String (1 .. Hex_Address_Width + 21); + + use type System.Task_Info.Task_Image_Type; + + begin + Clear (Buf'Unchecked_Access); + Put (T, Hex_Address_Width, Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + + if T.Common.Task_Image = null then + Put ("", 15, Buf'Unchecked_Access); + else + Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access); + end if; + + for J in Result'Range loop + Result (J) := Buf.Chars (J); + end loop; + + return Result; + end Image; + + ---------------- + -- List_Tasks -- + ---------------- + + procedure List_Tasks is + C : ST.Task_ID; + + begin + Print_Task_Info_Header; + C := All_Tasks_List; + + while C /= null loop + Print_Task_Info (C); + C := C.Common.All_Tasks_Link; + end loop; + end List_Tasks; + + ----------------------- + -- Print_Accept_Info -- + ----------------------- + + procedure Print_Accept_Info (T : ST.Task_ID) is + Buf : aliased Buffer; + + begin + if T.Open_Accepts = null then + return; + end if; + + Clear (Buf'Unchecked_Access); + Space (10, Buf'Unchecked_Access); + Put ("accepting:", 11, Buf'Unchecked_Access); + + for J in T.Open_Accepts.all'Range loop + Put (Integer_Address (T.Open_Accepts (J).S), 3, Buf'Unchecked_Access); + end loop; + + Write_Buf (Buf'Unchecked_Access); + end Print_Accept_Info; + + ------------------------ + -- Print_Current_Task -- + ------------------------ + + procedure Print_Current_Task is + begin + Print_Task_Info (STPO.Self); + end Print_Current_Task; + + --------------------- + -- Print_Task_Info -- + --------------------- + + procedure Print_Task_Info (T : ST.Task_ID) is + Entry_Call : Entry_Call_Link; + Buf : aliased Buffer; + + use type System.Task_Info.Task_Image_Type; + + begin + Clear (Buf'Unchecked_Access); + Put (T, Hex_Address_Width, Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + Put (' ', Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + + if T = null then + Put (" null task", 10, Buf'Unchecked_Access); + Write_Buf (Buf'Unchecked_Access); + return; + end if; + + Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + + if T.Common.Task_Image = null then + Put ("", 15, Buf'Unchecked_Access); + else + Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access); + end if; + + Space (Buf'Unchecked_Access); + Put (Task_States'Image (T.Common.State), 10, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + + if T.Callable then + Put ('C', Buf'Unchecked_Access); + else + Space (Buf'Unchecked_Access); + end if; + + if T.Open_Accepts /= null then + Put ('A', Buf'Unchecked_Access); + else + Space (Buf'Unchecked_Access); + end if; + + if T.Common.Call /= null then + Put ('C', Buf'Unchecked_Access); + else + Space (Buf'Unchecked_Access); + end if; + + if T.Terminate_Alternative then + Put ('T', Buf'Unchecked_Access); + else + Space (Buf'Unchecked_Access); + end if; + + if T.Aborting then + Put ('A', Buf'Unchecked_Access); + else + Space (Buf'Unchecked_Access); + end if; + + if T.Deferral_Level = 0 then + Space (3, Buf'Unchecked_Access); + else + Put ('D', Buf'Unchecked_Access); + if T.Deferral_Level < 0 then + Put ("<0", 2, Buf'Unchecked_Access); + elsif T.Deferral_Level > 1 then + Put (Integer_Address (T.Deferral_Level), 2, Buf'Unchecked_Access); + else + Space (2, Buf'Unchecked_Access); + end if; + end if; + + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.Master_of_Task), 1, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.Master_Within), 1, Buf'Unchecked_Access); + Put (',', Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.Awake_Count), 1, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.Alive_Count), 1, Buf'Unchecked_Access); + Put (',', Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.ATC_Nesting_Level), 1, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.Pending_ATC_Level), 1, Buf'Unchecked_Access); + Put (',', Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.Common.Wait_Count), 1, Buf'Unchecked_Access); + Put (',', Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (Integer_Address (T.User_State), 1, Buf'Unchecked_Access); + Write_Buf (Buf'Unchecked_Access); + + if T.Common.Call /= null then + Entry_Call := T.Common.Call; + Clear (Buf'Unchecked_Access); + Space (10, Buf'Unchecked_Access); + Put ("serving:", 8, Buf'Unchecked_Access); + + while Entry_Call /= null loop + Put (Integer_Address + (Entry_Call.Self.Serial_Number), 5, Buf'Unchecked_Access); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + + Write_Buf (Buf'Unchecked_Access); + end if; + + Print_Accept_Info (T); + end Print_Task_Info; + + ---------------------------- + -- Print_Task_Info_Header -- + ---------------------------- + + procedure Print_Task_Info_Header is + Buf : aliased Buffer; + + begin + Clear (Buf'Unchecked_Access); + Put ("TASK_ID", Hex_Address_Width, Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + Put ('F', Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + Put ("SERIAL_NUMBER", 4, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + Put (" NAME", 15, Buf'Unchecked_Access); + Put (" STATE", 10, Buf'Unchecked_Access); + Space (11, Buf'Unchecked_Access); + Put ("MAST", 5, Buf'Unchecked_Access); + Put ("AWAK", 5, Buf'Unchecked_Access); + Put ("ATC", 5, Buf'Unchecked_Access); + Put ("WT", 3, Buf'Unchecked_Access); + Put ("DBG", 3, Buf'Unchecked_Access); + Write_Buf (Buf'Unchecked_Access); + end Print_Task_Info_Header; + + --------- + -- Put -- + --------- + + procedure Put + (T : ST.Task_ID; + Width : Integer; + Buffer : Buffer_Ptr) + is + J : Integer; + X : Integer_Address := +T; + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + First : constant Integer := Next; + Wdth : Integer := Width; + + begin + if Wdth > Buf'Last - Next then + Wdth := Buf'Last - Next; + end if; + + J := Next + (Wdth - 1); + + if X = 0 then + Buf (J) := '0'; + + else + while X > 0 loop + Buf (J) := Hex_Digits (X rem 16); + J := J - 1; + X := X / 16; + + -- Check for overflow + + if J < First and then X > 0 then + Buf (J + 1) := '*'; + exit; + end if; + + end loop; + end if; + + Next := Next + Wdth; + end Put; + + procedure Put + (N : Integer_Address; + Width : Integer; + Buffer : Buffer_Ptr) + is + J : Integer; + X : Integer_Address := N; + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + First : constant Integer := Next; + Wdth : Integer := Width; + + begin + if Wdth > Buf'Last - Next then + Wdth := Buf'Last - Next; + end if; + + J := Next + (Wdth - 1); + + if N = 0 then + Buf (J) := '0'; + + else + while X > 0 loop + Buf (J) := Hex_Digits (X rem 10); + J := J - 1; + X := X / 10; + + -- Check for overflow + + if J < First and then X > 0 then + Buf (J + 1) := '*'; + exit; + end if; + end loop; + end if; + + Next := Next + Wdth; + end Put; + + procedure Put + (S : String; + Width : Integer; + Buffer : Buffer_Ptr) + is + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + Bound : constant Integer := Integer'Min (Next + Width, Buf'Last); + J : Integer := Next; + + begin + for K in S'Range loop + + -- Check overflow + + if J >= Bound then + Buf (J - 1) := '*'; + exit; + end if; + + Buf (J) := S (K); + J := J + 1; + end loop; + + Next := Bound; + end Put; + + procedure Put + (C : Character; + Buffer : Buffer_Ptr) + is + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + + begin + if Next >= Buf'Last then + Buf (Next) := '*'; + else Buf (Next) := C; + Next := Next + 1; + end if; + end Put; + + ---------------------- + -- Resume_All_Tasks -- + ---------------------- + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : ST.Task_ID; + R : Boolean; + + begin + C := All_Tasks_List; + + while C /= null loop + R := STPO.Resume_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + end Resume_All_Tasks; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + begin + return STPO.Self; + end Self; + + --------------- + -- Set_Trace -- + --------------- + + procedure Set_Trace + (Flag : Character; + Value : Boolean := True) + is + begin + Trace_On (Flag) := Value; + end Set_Trace; + + -------------------- + -- Set_User_State -- + -------------------- + + procedure Set_User_State (Value : Integer) is + begin + STPO.Self.User_State := Value; + end Set_User_State; + + ----------- + -- Space -- + ----------- + + procedure Space (Buffer : Buffer_Ptr) is + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + + begin + if Next >= Buf'Last then + Buf (Next) := '*'; + else + Next := Next + 1; + end if; + end Space; + + procedure Space + (N : Integer; + Buffer : Buffer_Ptr) + is + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + + begin + if Next + N > Buf'Last then + Buf (Next) := '*'; + else + Next := Next + N; + end if; + end Space; + + ----------------------- + -- Suspend_All_Tasks -- + ----------------------- + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is + C : ST.Task_ID; + R : Boolean; + + begin + C := All_Tasks_List; + + while C /= null loop + R := STPO.Suspend_Task (C, Thread_Self); + C := C.Common.All_Tasks_Link; + end loop; + end Suspend_All_Tasks; + + ------------------------ + -- Task_Creation_Hook -- + ------------------------ + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is + pragma Inspection_Point (Thread); + -- gdb needs to access the thread parameter in order to implement + -- the multitask mode under VxWorks. + + begin + null; + end Task_Creation_Hook; + + --------------------------- + -- Task_Termination_Hook -- + --------------------------- + + procedure Task_Termination_Hook is + begin + null; + end Task_Termination_Hook; + + ----------- + -- Trace -- + ----------- + + procedure Trace + (Self_ID : ST.Task_ID; + Msg : String; + Other_ID : ST.Task_ID; + Flag : Character) + is + Buf : aliased Buffer; + use type System.Task_Info.Task_Image_Type; + + begin + if Trace_On (Flag) then + Clear (Buf'Unchecked_Access); + Put (Self_ID, Hex_Address_Width, Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + Put (Flag, Buf'Unchecked_Access); + Put (':', Buf'Unchecked_Access); + Put + (Integer_Address (Self_ID.Serial_Number), + 4, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + + if Self_ID.Common.Task_Image = null then + Put ("", 15, Buf'Unchecked_Access); + else + Put (Self_ID.Common.Task_Image.all, 15, Buf'Unchecked_Access); + end if; + + Space (Buf'Unchecked_Access); + + if Other_ID /= null then + Put + (Integer_Address (Other_ID.Serial_Number), + 4, Buf'Unchecked_Access); + Space (Buf'Unchecked_Access); + end if; + + Put (Msg, Buf.Chars'Last - Buf.Next + 1, Buf'Unchecked_Access); + Write_Buf (Buf'Unchecked_Access); + end if; + end Trace; + + procedure Trace + (Self_ID : ST.Task_ID; + Msg : String; + Flag : Character) + is + begin + Trace (Self_ID, Msg, null, Flag); + end Trace; + + procedure Trace + (Msg : String; + Flag : Character) + is + Self_ID : constant ST.Task_ID := STPO.Self; + + begin + Trace (Self_ID, Msg, null, Flag); + end Trace; + + procedure Trace + (Msg : String; + Other_ID : ST.Task_ID; + Flag : Character) + is + Self_ID : constant ST.Task_ID := STPO.Self; + + begin + Trace (Self_ID, Msg, null, Flag); + end Trace; + + --------------- + -- Write_Buf -- + --------------- + + procedure Write_Buf (Buffer : Buffer_Ptr) is + Next : Buf_Range renames Buffer.Next; + Buf : Buf_Array renames Buffer.Chars; + + procedure put_char (C : Integer); + pragma Import (C, put_char, "put_char"); + + begin + for J in 1 .. Next - 1 loop + put_char (Character'Pos (Buf (J))); + end loop; + + put_char (Character'Pos (ASCII.LF)); + end Write_Buf; + +end System.Tasking.Debug; diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads new file mode 100644 index 00000000000..b07ab445034 --- /dev/null +++ b/gcc/ada/s-tasdeb.ads @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . D E B U G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.16 $ +-- -- +-- Copyright (C) 1997-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 encapsulates all direct interfaces to task debugging services +-- that are needed by gdb with gnat mode (1.17 and higher) + +with Interfaces.C; +with System.Tasking; +with System.OS_Interface; + +package System.Tasking.Debug is + + subtype int is Interfaces.C.int; + subtype unsigned_long is Interfaces.C.unsigned_long; + + package ST renames System.Tasking; + + Known_Tasks : array (0 .. 999) of Task_ID; + -- Global array of tasks read by gdb, and updated by + -- Create_Task and Finalize_TCB + + procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id); + -- This procedure is used to notify VxGdb of task's creation. + -- It must be called by the task's creator. + + procedure Task_Termination_Hook; + -- This procedure is used to notify VxGdb of task's termination. + + function Self return Task_ID; + -- return system ID of current task + + procedure List_Tasks; + -- Print a list of all the known Ada tasks with abbreviated state + -- information, one-per-line, to the standard output file + + procedure Print_Current_Task; + procedure Print_Task_Info_Header; + procedure Print_Task_Info (T : Task_ID); + -- Write TASK_ID of current task, in hexadecimal, as one line, to + -- the standard output file + -- + -- Beware that Print_Current_Task may print garbage during an early + -- stage of activation. There is a small window where a task is just + -- initializing itself and has not yet recorded its own task Id. + -- + -- Beware that Print_Current_Task will either not work at all or print + -- garbage if it has interrupted a thread of control that does not + -- correspond to any Ada task. For example, this is could happen if + -- the debugger interrupts a signal handler that is using an alternate + -- stack, or interrupts the dispatcher in the underlying thread + -- implementation. + + procedure Set_User_State (Value : Integer); + + procedure Print_Accept_Info (T : Task_ID); + + procedure Trace + (Self_ID : Task_ID; + Msg : String; + Other_ID : Task_ID; + Flag : Character); + + procedure Trace + (Self_ID : Task_ID; + Msg : String; + Flag : Character); + + procedure Trace + (Msg : String; + Flag : Character); + + procedure Trace + (Msg : String; + Other_ID : Task_ID; + Flag : Character); + + procedure Set_Trace + (Flag : Character; + Value : Boolean := True); + + function Image (T : Task_ID) return String; + + procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id); + -- Suspend all the tasks except the one whose associated thread is + -- Thread_Self by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Suspend_Task + -- Such functionnality is needed by gdb on some targets (e.g VxWorks) + -- Warning: for efficiency purposes, there is no locking. + + procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id); + -- Resume all the tasks except the one whose associated thread is + -- Thread_Self by traversing All_Tasks_Lists and calling + -- System.Task_Primitives.Operations.Continue_Task + -- Such functionnality is needed by gdb on some targets (e.g VxWorks) + -- Warning: for efficiency purposes, there is no locking. + +end System.Tasking.Debug; + +----------------------------- +-- Use of These Functions -- +----------------------------- + +-- Calling complicated functions from the debugger is generally pretty +-- risky, especially in a multithreaded program. + +-- The debugger may interrupt something that is not an Ada task, +-- within the thread implementation, and which is not async-safe. + +-- For example, under Solaris, it can interrupt code in "_dynamiclwps", +-- which seems to serve as dispatcher when all the user threads are +-- suspended. By experience, we have found that one cannot safely +-- do certain things, apparently including calls to thread primitives +-- from the debugger if the debugger has interrupted at one of these +-- unsafe points. In general, if you interrupt a running program +-- asynchronously (e.g. via control-C), it will not be safe to +-- call the subprograms in this package. + +----------------- +-- Future work -- +----------------- + +-- It would be nice to be able to tell whether execution has been +-- interrupted in an Ada task. A heuristic way of checking this would +-- be if we added to the Ada TCB a component that always contains a +-- constant value that is unlikely to occur accidentally in code or +-- data. We could then check this in the debugger-callable subprograms, +-- and simply return an error code if it looks unsafe to proceed. + +-- ??? +-- Recently we have added such a marker as a local variable of the +-- task-wrapper routine. This allows Self to generate a fake ATCB for +-- non-Ada threads of control. Given this capability, it is probably +-- time to revisit the issue above. + +-- DEADLOCK + +-- We follow a simple rule here to avoid deadlock: + +-- We do not use any locks in functions called by gdb, and we do not +-- traverse linked lists. +-- +-- The use of an array (Known_Tasks) has many advantages: + +-- - Easy and fast to examine; +-- - No risk of dangling references (to the next element) when traversing +-- the array. diff --git a/gcc/ada/s-tasinf.adb b/gcc/ada/s-tasinf.adb new file mode 100644 index 00000000000..6595f402bb5 --- /dev/null +++ b/gcc/ada/s-tasinf.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- (Compiler Interface) -- +-- -- +-- $Revision: 1.4 $ -- +-- -- +-- Copyright (C) 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 a dummy version of this package that is needed to solve bootstrap +-- problems when compiling a library that doesn't require s-tasinf.adb from +-- a compiler that contains one. + +-- This package contains the definitions and routines associated with the +-- implementation of the Task_Info pragma. + +package body System.Task_Info is + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf.ads b/gcc/ada/s-tasinf.ads new file mode 100644 index 00000000000..f2bf26ead6f --- /dev/null +++ b/gcc/ada/s-tasinf.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- (Compiler Interface) -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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 definitions and routines associated with the +-- implementation of the Task_Info pragma. It is specialized appropriately +-- for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Unchecked_Deallocation; +package System.Task_Info is +pragma Elaborate_Body; +-- To ensure that a body is allowed + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ------------------ + -- Declarations -- + ------------------ + + type Scope_Type is + (Process_Scope, + -- Contend only with threads in same process + + System_Scope, + -- Contend with all threads on same CPU + + Default_Scope); + + type Task_Info_Type is new Scope_Type; + -- Type used for passing information to task create call, using the + -- Task_Info pragma. This type may be specialized for individual + -- implementations, but it must be a type that can be used as a + -- discriminant (i.e. a scalar or access type). + + type Task_Image_Type is access String; + -- Used to generate a meaningful identifier for tasks that are variables + -- and components of variables. + + procedure Free_Task_Image is new + Unchecked_Deallocation (String, Task_Image_Type); + + Unspecified_Task_Info : constant Task_Info_Type := Default_Scope; + -- Value passed to task in the absence of a Task_Info pragma + +end System.Task_Info; diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb new file mode 100644 index 00000000000..08d778f9231 --- /dev/null +++ b/gcc/ada/s-tasini.adb @@ -0,0 +1,981 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.63 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram alpha ordering check, since we group soft link +-- bodies and dummy soft link bodies together separately in this unit. + +pragma Polling (Off); +-- Turn polling off for this package. We don't need polling during any +-- of the routines in this package, and more to the point, if we try +-- to poll it can cause infinite loops. + +-- This package provides overall initialization of the tasking portion +-- of the RTS. This package must be elaborated before any tasking +-- features are used. It also contains initialization for +-- Ada Task Control Block (ATCB) records. + +with Ada.Exceptions; +-- used for Exception_Occurrence_Access. + +with System.Tasking; +pragma Elaborate_All (System.Tasking); +-- ensure that the first step initializations have been performed + +with System.Task_Primitives; +-- used for Lock + +with System.Task_Primitives.Operations; +-- used for Set_Priority +-- Write_Lock +-- Unlock +-- Initialize_Lock + +with System.Soft_Links; +-- used for the non-tasking routines (*_NT) that refer to global data. +-- They are needed here before the tasking run time has been elaborated. + +with System.Tasking.Debug; +-- used for Trace + +with System.Tasking.Task_Attributes; +-- used for All_Attrs_L + +with System.Stack_Checking; + +package body System.Tasking.Initialization is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package AE renames Ada.Exceptions; + + use System.Task_Primitives.Operations; + + Global_Task_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion + -- from all other tasks. It is only used by Task_Lock, + -- Task_Unlock, and Final_Task_Unlock. + + function Current_Target_Exception return AE.Exception_Occurrence; + pragma Import + (Ada, Current_Target_Exception, "__gnat_current_target_exception"); + -- Import this subprogram from the private part of Ada.Exceptions. + + ----------------------------------------------------------------- + -- Tasking versions of services needed by non-tasking programs -- + ----------------------------------------------------------------- + + procedure Task_Lock; + -- Locks out other tasks. Preceding a section of code by Task_Lock and + -- following it by Task_Unlock creates a critical region. This is used + -- for ensuring that a region of non-tasking code (such as code used to + -- allocate memory) is tasking safe. Note that it is valid for calls to + -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. + -- only the corresponding outer level Task_Unlock will actually unlock. + + procedure Task_Unlock; + -- Releases lock previously set by call to Task_Lock. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + + function Get_Jmpbuf_Address return Address; + procedure Set_Jmpbuf_Address (Addr : Address); + -- Get/Set Jmpbuf_Address for current task + + function Get_Sec_Stack_Addr return Address; + procedure Set_Sec_Stack_Addr (Addr : Address); + -- Get/Set location of current task's secondary stack + + function Get_Exc_Stack_Addr return Address; + -- Get the exception stack for the current task + + procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address); + -- Self_ID is the Task_ID of the task that gets the exception stack. + -- For Self_ID = Null_Address, the current task gets the exception stack. + + function Get_Machine_State_Addr return Address; + procedure Set_Machine_State_Addr (Addr : Address); + -- Get/Set the address for storing the current task's machine state + + function Get_Current_Excep return SSL.EOA; + -- Comments needed??? + + procedure Timed_Delay_T (Time : Duration; Mode : Integer); + -- Comments needed??? + + function Get_Stack_Info return Stack_Checking.Stack_Access; + -- Get access to the current task's Stack_Info + + procedure Update_Exception + (X : AE.Exception_Occurrence := Current_Target_Exception); + -- Handle exception setting and check for pending actions + + ------------------------ + -- Local Subprograms -- + ------------------------ + + procedure Do_Pending_Action (Self_ID : Task_ID); + -- This is introduced to allow more efficient + -- in-line expansion of Undefer_Abort. + + ---------------------------- + -- Tasking Initialization -- + ---------------------------- + + procedure Init_RTS; + -- This procedure completes the initialization of the GNARL. The first + -- part of the initialization is done in the body of System.Tasking. + -- It consists of initializing global locks, and installing tasking + -- versions of certain operations used by the compiler. Init_RTS is called + -- during elaboration. + + -------------------------- + -- Change_Base_Priority -- + -------------------------- + + -- Call only with abort deferred and holding Self_ID locked. + + procedure Change_Base_Priority (T : Task_ID) is + begin + if T.Common.Base_Priority /= T.New_Base_Priority then + T.Common.Base_Priority := T.New_Base_Priority; + Set_Priority (T, T.Common.Base_Priority); + end if; + end Change_Base_Priority; + + ------------------------ + -- Check_Abort_Status -- + ------------------------ + + function Check_Abort_Status return Integer is + Self_ID : Task_ID := Self; + + begin + if Self_ID /= null and then Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + return 1; + else + return 0; + end if; + end Check_Abort_Status; + + ----------------- + -- Defer_Abort -- + ----------------- + + procedure Defer_Abort (Self_ID : Task_ID) is + begin + + pragma Assert (Self_ID.Deferral_Level = 0); + +-- pragma Assert +-- (Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level); + + -- The above check has been useful in detecting mismatched + -- defer/undefer pairs. You may uncomment it when testing on + -- systems that support preemptive abort. + + -- If the OS supports preemptive abort (e.g. pthread_kill), + -- it should have happened already. A problem is with systems + -- that do not support preemptive abort, and so rely on polling. + -- On such systems we may get false failures of the assertion, + -- since polling for pending abort does no occur until the abort + -- undefer operation. + + -- Even on systems that only poll for abort, the assertion may + -- be useful for catching missed abort completion polling points. + -- The operations that undefer abort poll for pending aborts. + -- This covers most of the places where the core Ada semantics + -- require abort to be caught, without any special attention. + -- However, this generally happens on exit from runtime system + -- call, which means a pending abort will not be noticed on the + -- way into the runtime system. We considered adding a check + -- for pending aborts at this point, but chose not to, because + -- of the overhead. Instead, we searched for RTS calls that + -- where abort completion is required and a task could go + -- farther than Ada allows before undeferring abort; we then + -- modified the code to ensure the abort would be detected. + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abort; + + -------------------------- + -- Defer_Abort_Nestable -- + -------------------------- + + procedure Defer_Abort_Nestable (Self_ID : Task_ID) is + begin + +-- pragma Assert +-- ((Self_ID.Pending_ATC_Level >= Self_ID.ATC_Nesting_Level or else +-- Self_ID.Deferral_Level > 0)); + + -- See comment in Defer_Abort on the situations in which it may + -- be useful to uncomment the above assertion. + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abort_Nestable; + + -------------------- + -- Defer_Abortion -- + -------------------- + + -- ?????? + -- Phase out Defer_Abortion without Self_ID + -- to reduce overhead due to multiple calls to Self + + procedure Defer_Abortion is + Self_ID : constant Task_ID := STPO.Self; + + begin + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + end Defer_Abortion; + + ----------------------- + -- Do_Pending_Action -- + ----------------------- + + -- Call only when holding no locks + + procedure Do_Pending_Action (Self_ID : Task_ID) is + use type Ada.Exceptions.Exception_Id; + + begin + pragma Assert (Self_ID = Self and then Self_ID.Deferral_Level = 0); + + -- Needs loop to recheck for pending action in case a new one occurred + -- while we had abort deferred below. + + loop + -- Temporarily defer abortion so that we can lock Self_ID. + + Self_ID.Deferral_Level := Self_ID.Deferral_Level + 1; + + Write_Lock (Self_ID); + Self_ID.Pending_Action := False; + Poll_Base_Priority_Change (Self_ID); + Unlock (Self_ID); + + -- Restore the original Deferral value. + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if not Self_ID.Pending_Action then + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + if not Self_ID.Aborting then + Self_ID.Aborting := True; + pragma Debug + (Debug.Trace (Self_ID, "raise Abort_Signal", 'B')); + raise Standard'Abort_Signal; + + pragma Assert (not Self_ID.ATC_Hack); + + elsif Self_ID.ATC_Hack then + -- The solution really belongs in the Abort_Signal handler + -- for async. entry calls. The present hack is very + -- fragile. It relies that the very next point after + -- Exit_One_ATC_Level at which the task becomes abortable + -- will be the call to Undefer_Abort in the + -- Abort_Signal handler. + + Self_ID.ATC_Hack := False; + + pragma Debug + (Debug.Trace + (Self_ID, "raise Abort_Signal (ATC hack)", 'B')); + raise Standard'Abort_Signal; + end if; + end if; + + return; + end if; + end loop; + end Do_Pending_Action; + + ----------------------- + -- Final_Task_Unlock -- + ----------------------- + + -- This version is only for use in Terminate_Task, when the task + -- is relinquishing further rights to its own ATCB. + -- There is a very interesting potential race condition there, where + -- the old task may run concurrently with a new task that is allocated + -- the old tasks (now reused) ATCB. The critical thing here is to + -- not make any reference to the ATCB after the lock is released. + -- See also comments on Terminate_Task and Unlock. + + procedure Final_Task_Unlock (Self_ID : Task_ID) is + begin + pragma Assert (Self_ID.Global_Task_Lock_Nesting = 1); + Unlock (Global_Task_Lock'Access); + end Final_Task_Unlock; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + Self_Id : Task_ID; + begin + -- Terminate run time (regular vs restricted) specific initialization + -- of the environment task. + + Self_Id := Environment_Task; + Self_Id.Master_of_Task := Environment_Task_Level; + Self_Id.Master_Within := Self_Id.Master_of_Task + 1; + + for L in Self_Id.Entry_Calls'Range loop + Self_Id.Entry_Calls (L).Self := Self_Id; + Self_Id.Entry_Calls (L).Level := L; + end loop; + + Self_Id.Awake_Count := 1; + Self_Id.Alive_Count := 1; + + Self_Id.Master_Within := Library_Task_Level; + -- Normally, a task starts out with internal master nesting level + -- one larger than external master nesting level. It is incremented + -- to one by Enter_Master, which is called in the task body only if + -- the compiler thinks the task may have dependent tasks. There is no + -- corresponding call to Enter_Master for the environment task, so we + -- would need to increment it to 2 here. Instead, we set it to 3. + -- By doing this we reserve the level 2 for server tasks of the runtime + -- system. The environment task does not need to wait for these server + + -- Initialize lock used to implement mutual exclusion between all tasks + + Initialize_Lock (Global_Task_Lock'Access, STPO.Global_Task_Level); + + -- Initialize lock used to implement mutual exclusion in the package + -- System.Task_Attributes. + + Initialize_Lock (System.Tasking.Task_Attributes.All_Attrs_L'Access, + All_Attrs_Level); + + -- Notify that the tasking run time has been elaborated so that + -- the tasking version of the soft links can be used. + + SSL.Abort_Defer := Defer_Abortion'Access; + SSL.Abort_Undefer := Undefer_Abortion'Access; + SSL.Update_Exception := Update_Exception'Access; + SSL.Lock_Task := Task_Lock'Access; + SSL.Unlock_Task := Task_Unlock'Access; + SSL.Get_Jmpbuf_Address := Get_Jmpbuf_Address'Access; + SSL.Set_Jmpbuf_Address := Set_Jmpbuf_Address'Access; + SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; + SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access; + SSL.Set_Exc_Stack_Addr := Set_Exc_Stack_Addr'Access; + SSL.Get_Machine_State_Addr := Get_Machine_State_Addr'Access; + SSL.Set_Machine_State_Addr := Set_Machine_State_Addr'Access; + SSL.Get_Current_Excep := Get_Current_Excep'Access; + SSL.Timed_Delay := Timed_Delay_T'Access; + SSL.Check_Abort_Status := Check_Abort_Status'Access; + SSL.Get_Stack_Info := Get_Stack_Info'Access; + + -- No need to create a new Secondary Stack, since we will use the + -- default one created in s-secsta.adb + + SSL.Set_Sec_Stack_Addr (SSL.Get_Sec_Stack_Addr_NT); + SSL.Set_Exc_Stack_Addr (Null_Address, SSL.Get_Exc_Stack_Addr_NT); + SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT); + SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT); + + -- Abortion is deferred in a new ATCB, so we need to undefer abortion + -- at this stage to make the environment task abortable. + + Undefer_Abort (Environment_Task); + end Init_RTS; + + --------------------------- + -- Locked_Abort_To_Level-- + --------------------------- + + -- Abort a task to the specified ATC nesting level. + -- Call this only with T locked. + + -- An earlier version of this code contained a call to Wakeup. That + -- should not be necessary here, if Abort_Task is implemented correctly, + -- since Abort_Task should include the effect of Wakeup. However, the + -- above call was in earlier versions of this file, and at least for + -- some targets Abort_Task has not beek doing Wakeup. It should not + -- hurt to uncomment the above call, until the error is corrected for + -- all targets. + + -- See extended comments in package body System.Tasking.Abortion + -- for the overall design of the implementation of task abort. + + -- If the task is sleeping it will be in an abort-deferred region, + -- and will not have Abort_Signal raised by Abort_Task. + -- Such an "abort deferral" is just to protect the RTS internals, + -- and not necessarily required to enforce Ada semantics. + -- Abort_Task should wake the task up and let it decide if it wants + -- to complete the aborted construct immediately. + + -- Note that the effect of the lowl-level Abort_Task is not persistent. + -- If the target task is not blocked, this wakeup will be missed. + + -- We don't bother calling Abort_Task if this task is aborting itself, + -- since we are inside the RTS and have abort deferred. Similarly, We + -- don't bother to call Abort_Task if T is terminated, since there is + -- no need to abort a terminated task, and it could be dangerous to try + -- if the task has stopped executing. + + -- Note that an earlier version of this code had some false reasoning + -- about being able to reliably wake up a task that had suspended on + -- a blocking system call that does not atomically relase the task's + -- lock (e.g., UNIX nanosleep, which we once thought could be used to + -- implement delays). That still left the possibility of missed + -- wakeups. + + -- We cannot safely call Vulnerable_Complete_Activation here, + -- since that requires locking Self_ID.Parent. The anti-deadlock + -- lock ordering rules would then require us to release the lock + -- on Self_ID first, which would create a timing window for other + -- tasks to lock Self_ID. This is significant for tasks that may be + -- aborted before their execution can enter the task body, and so + -- they do not get a chance to call Complete_Task. The actual work + -- for this case is done in Terminate_Task. + + procedure Locked_Abort_To_Level + (Self_ID : Task_ID; + T : Task_ID; + L : ATC_Level) is + + begin + if not T.Aborting and then T /= Self_ID then + case T.Common.State is + when Unactivated | Terminated => + pragma Assert (False); + null; + + when Runnable => + -- This is needed to cancel an asynchronous protected entry + -- call during a requeue with abort. + + T.Entry_Calls + (T.ATC_Nesting_Level).Cancellation_Attempted := True; + + when Interrupt_Server_Blocked_On_Event_Flag => + null; + + when Delay_Sleep | + Async_Select_Sleep | + Interrupt_Server_Idle_Sleep | + Interrupt_Server_Blocked_Interrupt_Sleep | + Timer_Server_Sleep | + AST_Server_Sleep => + Wakeup (T, T.Common.State); + + when Acceptor_Sleep => + T.Open_Accepts := null; + Wakeup (T, T.Common.State); + + when Entry_Caller_Sleep => + T.Entry_Calls + (T.ATC_Nesting_Level).Cancellation_Attempted := True; + Wakeup (T, T.Common.State); + + when Activator_Sleep | + Master_Completion_Sleep | + Master_Phase_2_Sleep | + Asynchronous_Hold => + null; + end case; + end if; + + if T.Pending_ATC_Level > L then + T.Pending_ATC_Level := L; + T.Pending_Action := True; + + if L = 0 then + T.Callable := False; + end if; + + -- This prevents aborted task from accepting calls + + if T.Aborting then + + -- The test above is just a heuristic, to reduce wasteful + -- calls to Abort_Task. We are holding T locked, and this + -- value will not be set to False except with T also locked, + -- inside Exit_One_ATC_Level, so we should not miss wakeups. + + if T.Common.State = Acceptor_Sleep then + T.Open_Accepts := null; + end if; + + elsif T /= Self_ID and then + (T.Common.State = Runnable + or else T.Common.State = Interrupt_Server_Blocked_On_Event_Flag) + -- The task is blocked on a system call waiting for the + -- completion event. In this case Abort_Task may need to take + -- special action in order to succeed. Example system: VMS. + + then + Abort_Task (T); + end if; + end if; + end Locked_Abort_To_Level; + + ------------------------------- + -- Poll_Base_Priority_Change -- + ------------------------------- + + -- Poll for pending base priority change and for held tasks. + -- This should always be called with (only) Self_ID locked. + -- It may temporarily release Self_ID's lock. + + -- The call to Yield is to force enqueuing at the + -- tail of the dispatching queue. + + -- We must unlock Self_ID for this to take effect, + -- since we are inheriting high active priority from the lock. + + -- See also Poll_Base_Priority_Change_At_Entry_Call, + -- in package System.Tasking.Entry_Calls. + + -- In this version, we check if the task is held too because + -- doing this only in Do_Pending_Action is not enough. + + procedure Poll_Base_Priority_Change (Self_ID : Task_ID) is + begin + if Dynamic_Priority_Support + and then Self_ID.Pending_Priority_Change + then + -- Check for ceiling violations ??? + + Self_ID.Pending_Priority_Change := False; + + if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then + Unlock (Self_ID); + Yield; + Write_Lock (Self_ID); + + elsif Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + + else + -- Lowering priority + + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + Unlock (Self_ID); + Yield; + Write_Lock (Self_ID); + end if; + end if; + end Poll_Base_Priority_Change; + + -------------------------------- + -- Remove_From_All_Tasks_List -- + -------------------------------- + + procedure Remove_From_All_Tasks_List (T : Task_ID) is + C : Task_ID; + Previous : Task_ID; + + begin + pragma Debug + (Debug.Trace ("Remove_From_All_Tasks_List", 'C')); + + Lock_All_Tasks_List; + + Previous := Null_Task; + C := All_Tasks_List; + while C /= Null_Task loop + if C = T then + if Previous = Null_Task then + All_Tasks_List := + All_Tasks_List.Common.All_Tasks_Link; + else + Previous.Common.All_Tasks_Link := C.Common.All_Tasks_Link; + end if; + + Unlock_All_Tasks_List; + return; + end if; + + Previous := C; + C := C.Common.All_Tasks_Link; + end loop; + + pragma Assert (False); + end Remove_From_All_Tasks_List; + + --------------- + -- Task_Lock -- + --------------- + + procedure Task_Lock is + T : Task_ID := STPO.Self; + + begin + T.Global_Task_Lock_Nesting := T.Global_Task_Lock_Nesting + 1; + + if T.Global_Task_Lock_Nesting = 1 then + Defer_Abort_Nestable (T); + Write_Lock (Global_Task_Lock'Access); + end if; + end Task_Lock; + + procedure Task_Lock (Self_ID : Task_ID) is + begin + Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting + 1; + + if Self_ID.Global_Task_Lock_Nesting = 1 then + Defer_Abort_Nestable (Self_ID); + Write_Lock (Global_Task_Lock'Access); + end if; + end Task_Lock; + + ----------------- + -- Task_Unlock -- + ----------------- + + procedure Task_Unlock is + T : Task_ID := STPO.Self; + + begin + pragma Assert (T.Global_Task_Lock_Nesting > 0); + + T.Global_Task_Lock_Nesting := T.Global_Task_Lock_Nesting - 1; + + if T.Global_Task_Lock_Nesting = 0 then + Unlock (Global_Task_Lock'Access); + Undefer_Abort_Nestable (T); + end if; + end Task_Unlock; + + procedure Task_Unlock (Self_ID : Task_ID) is + begin + Self_ID.Global_Task_Lock_Nesting := Self_ID.Global_Task_Lock_Nesting - 1; + + if Self_ID.Global_Task_Lock_Nesting = 0 then + Unlock (Global_Task_Lock'Access); + Undefer_Abort_Nestable (Self_ID); + end if; + end Task_Unlock; + + ------------------- + -- Undefer_Abort -- + ------------------- + + -- Precondition : Self does not hold any locks! + + -- Undefer_Abort is called on any abortion completion point (aka. + -- synchronization point). It performs the following actions if they + -- are pending: (1) change the base priority, (2) abort the task, + -- (3) raise a pending exception. + + -- The priority change has to occur before abortion. Otherwise, it would + -- take effect no earlier than the next abortion completion point. + + procedure Undefer_Abort (Self_ID : Task_ID) is + begin + pragma Assert (Self_ID.Deferral_Level = 1); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abort; + + ---------------------------- + -- Undefer_Abort_Nestable -- + ---------------------------- + + -- An earlier version would re-defer abort if an abort is + -- in progress. Then, we modified the effect of the raise + -- statement so that it defers abort until control reaches a + -- handler. That was done to prevent "skipping over" a + -- handler if another asynchronous abort occurs during the + -- propagation of the abort to the handler. + + -- There has been talk of reversing that decision, based on + -- a newer implementation of exception propagation. Care must + -- be taken to evaluate how such a change would interact with + -- the above code and all the places where abort-deferral is + -- used to bridge over critical transitions, such as entry to + -- the scope of a region with a finalizer and entry into the + -- body of an accept-procedure. + + procedure Undefer_Abort_Nestable (Self_ID : Task_ID) is + begin + pragma Assert (Self_ID.Deferral_Level > 0); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abort_Nestable; + + ---------------------- + -- Undefer_Abortion -- + ---------------------- + + -- Phase out RTS-internal use of Undefer_Abortion + -- to reduce overhead due to multiple calls to Self. + + procedure Undefer_Abortion is + Self_ID : constant Task_ID := STPO.Self; + + begin + pragma Assert (Self_ID.Deferral_Level > 0); + + Self_ID.Deferral_Level := Self_ID.Deferral_Level - 1; + + if Self_ID.Deferral_Level = 0 then + pragma Assert (Check_No_Locks (Self_ID)); + + if Self_ID.Pending_Action then + Do_Pending_Action (Self_ID); + end if; + end if; + end Undefer_Abortion; + + ---------------------- + -- Update_Exception -- + ---------------------- + + -- Call only when holding no locks. + + procedure Update_Exception + (X : AE.Exception_Occurrence := Current_Target_Exception) + is + Self_Id : constant Task_ID := Self; + use Ada.Exceptions; + + begin + Save_Occurrence (Self_Id.Common.Compiler_Data.Current_Excep, X); + + if Self_Id.Deferral_Level = 0 then + if Self_Id.Pending_Action then + Self_Id.Pending_Action := False; + Self_Id.Deferral_Level := Self_Id.Deferral_Level + 1; + Write_Lock (Self_Id); + Self_Id.Pending_Action := False; + Poll_Base_Priority_Change (Self_Id); + Unlock (Self_Id); + Self_Id.Deferral_Level := Self_Id.Deferral_Level - 1; + + if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then + if not Self_Id.Aborting then + Self_Id.Aborting := True; + raise Standard'Abort_Signal; + end if; + end if; + end if; + end if; + end Update_Exception; + + -------------------------- + -- Wakeup_Entry_Caller -- + -------------------------- + + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if it + -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. + + -- (This enforces the rule that a task must be off-queue if its state is + -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. + + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) + -- to complete. + + -- Asynchronous_Call: + -- The caller may be executing in the abortable part o + -- an async. select, or on a time delay, + -- if Entry_Call.State >= Was_Abortable. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + is + Caller : constant Task_ID := Entry_Call.Self; + + begin + pragma Debug (Debug.Trace + (Self_ID, "Wakeup_Entry_Caller", Caller, 'E')); + pragma Assert (New_State = Done or else New_State = Cancelled); + + pragma Assert + (Caller.Common.State /= Terminated + and then Caller.Common.State /= Unactivated); + + Entry_Call.State := New_State; + + if Entry_Call.Mode = Asynchronous_Call then + + -- Abort the caller in his abortable part, + -- but do so only if call has been queued abortably + + if Entry_Call.State >= Was_Abortable or else New_State = Done then + Locked_Abort_To_Level (Self_ID, Caller, Entry_Call.Level - 1); + end if; + + elsif Caller.Common.State = Entry_Caller_Sleep then + Wakeup (Caller, Entry_Caller_Sleep); + end if; + end Wakeup_Entry_Caller; + + ---------------------- + -- Soft-Link Bodies -- + ---------------------- + + function Get_Current_Excep return SSL.EOA is + Me : constant Task_ID := STPO.Self; + + begin + return Me.Common.Compiler_Data.Current_Excep'Access; + end Get_Current_Excep; + + function Get_Exc_Stack_Addr return Address is + Me : constant Task_ID := STPO.Self; + + begin + return Me.Common.Compiler_Data.Exc_Stack_Addr; + end Get_Exc_Stack_Addr; + + function Get_Jmpbuf_Address return Address is + Me : constant Task_ID := STPO.Self; + + begin + return Me.Common.Compiler_Data.Jmpbuf_Address; + end Get_Jmpbuf_Address; + + function Get_Machine_State_Addr return Address is + Me : constant Task_ID := STPO.Self; + + begin + return Me.Common.Compiler_Data.Machine_State_Addr; + end Get_Machine_State_Addr; + + function Get_Sec_Stack_Addr return Address is + Me : constant Task_ID := STPO.Self; + + begin + return Me.Common.Compiler_Data.Sec_Stack_Addr; + end Get_Sec_Stack_Addr; + + function Get_Stack_Info return Stack_Checking.Stack_Access is + Me : constant Task_ID := STPO.Self; + + begin + return Me.Common.Compiler_Data.Pri_Stack_Info'Access; + end Get_Stack_Info; + + procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address) is + Me : Task_ID := To_Task_Id (Self_ID); + + begin + if Me = Null_Task then + Me := STPO.Self; + end if; + + Me.Common.Compiler_Data.Exc_Stack_Addr := Addr; + end Set_Exc_Stack_Addr; + + procedure Set_Jmpbuf_Address (Addr : Address) is + Me : Task_ID := STPO.Self; + + begin + Me.Common.Compiler_Data.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address; + + procedure Set_Machine_State_Addr (Addr : Address) is + Me : Task_ID := STPO.Self; + + begin + Me.Common.Compiler_Data.Machine_State_Addr := Addr; + end Set_Machine_State_Addr; + + procedure Set_Sec_Stack_Addr (Addr : Address) is + Me : Task_ID := STPO.Self; + + begin + Me.Common.Compiler_Data.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr; + + procedure Timed_Delay_T (Time : Duration; Mode : Integer) is + Self_ID : constant Task_ID := Self; + + begin + STPO.Timed_Delay (Self_ID, Time, Mode); + end Timed_Delay_T; + + ------------------------ + -- Soft-Link Dummies -- + ------------------------ + + -- These are dummies for subprograms that are only needed by certain + -- optional run-time system packages. If they are needed, the soft + -- links will be redirected to the real subprogram by elaboration of + -- the subprogram body where the real subprogram is declared. + + procedure Finalize_Attributes (T : Task_ID) is + begin + null; + end Finalize_Attributes; + + procedure Initialize_Attributes (T : Task_ID) is + begin + null; + end Initialize_Attributes; + +begin + Init_RTS; +end System.Tasking.Initialization; diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads new file mode 100644 index 00000000000..56381c60bcf --- /dev/null +++ b/gcc/ada/s-tasini.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . I N I T I A L I Z A T I O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.24 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides overall initialization of the tasking portion of the +-- RTS. This package must be elaborated before any tasking features are used. +-- It also contains initialization for Ada Task Control Block (ATCB) records. + +package System.Tasking.Initialization is + + procedure Remove_From_All_Tasks_List (T : Task_ID); + -- Remove T from All_Tasks_List. + + ------------------------------------------------ + -- Static (Compile-Time) Configuration Flags -- + ------------------------------------------------ + + -- ????? + -- Maybe this does not belong here? Where else? + -- For now, it is here because so is Change_Base_Priority, + -- and the two are used together. + + Dynamic_Priority_Support : constant Boolean := True; + -- Should we poll for pending base priority changes at every + -- abort completion point? + + --------------------------------- + -- Tasking-Specific Soft Links -- + --------------------------------- + + -- These permit us to leave out certain portions of the tasking + -- run-time system if they are not used. They are only used internally + -- by the tasking run-time system. + -- So far, the only example is support for Ada.Task_Attributes. + + type Proc_T is access procedure (T : Task_ID); + + procedure Finalize_Attributes (T : Task_ID); + procedure Initialize_Attributes (T : Task_ID); + + Finalize_Attributes_Link : Proc_T := Finalize_Attributes'Access; + -- should be called with abortion deferred and T.L write-locked + + Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access; + -- should be called with abortion deferred, but holding no locks + + ------------------------- + -- Abort Defer/Undefer -- + ------------------------- + + -- Defer_Abort defers the affects of low-level abort and priority change + -- in the calling task until a matching Undefer_Abort call is executed. + + -- Undefer_Abort DOES MORE than just undo the effects of one call to + -- Defer_Abort. It is the universal "polling point" for deferred + -- processing, including the following: + + -- 1) base priority changes + + -- 2) exceptions that need to be raised + + -- 3) abort/ATC + + -- Abort deferral MAY be nested (Self_ID.Deferral_Level is a count), + -- but to avoid waste and undetected errors, it generally SHOULD NOT + -- be nested. The symptom of over-deferring abort is that an exception + -- may fail to be raised, or an abort may fail to take place. + + -- Therefore, there are two sets of the inlinable defer/undefer + -- routines, which are the ones to be used inside GNARL. + -- One set allows nesting. The other does not. People who + -- maintain the GNARL should try to avoid using the nested versions, + -- or at least look very critically at the places where they are + -- used. + + -- In general, any GNARL call that is potentially blocking, or + -- whose semantics require that it sometimes raise an exception, + -- or that is required to be an abort completion point, must be + -- made with abort Deferral_Level = 1. + + -- In general, non-blocking GNARL calls, which may be made from inside + -- a protected action, are likely to need to allow nested abort + -- deferral. + + -- With some critical exceptions (which are supposed to be documented), + -- internal calls to the tasking runtime system assume abort is already + -- deferred, and do not modify the deferral level. + + -- There is also a set of non-linable defer/undefer routines, + -- for direct call from the compiler. These are not in-lineable + -- because they may need to be called via pointers ("soft links"). + -- For the sake of efficiency, the version with Self_ID as parameter + -- should used wherever possible. These are all nestable. + + -- Non-nestable inline versions -- + + procedure Defer_Abort (Self_ID : Task_ID); + pragma Inline (Defer_Abort); + + procedure Undefer_Abort (Self_ID : Task_ID); + pragma Inline (Undefer_Abort); + + -- Nestable inline versions -- + + procedure Defer_Abort_Nestable (Self_ID : Task_ID); + pragma Inline (Defer_Abort_Nestable); + + procedure Undefer_Abort_Nestable (Self_ID : Task_ID); + pragma Inline (Undefer_Abort_Nestable); + + -- NON-INLINE versions without Self_ID for code generated by the + -- expander and for hard links + + procedure Defer_Abortion; + procedure Undefer_Abortion; + + -- ????? + -- Try to phase out all uses of the above versions. + + function Check_Abort_Status return Integer; + -- Returns Boolean'Pos (True) iff abort signal should raise + -- Standard.Abort_Signal. Only used by IRIX currently. + + --------------------------- + -- Change Base Priority -- + --------------------------- + + procedure Change_Base_Priority (T : Task_ID); + -- Change the base priority of T. + -- Has to be called with the affected task's ATCB write-locked. + -- May temporariliy release the lock. + + procedure Poll_Base_Priority_Change (Self_ID : Task_ID); + -- Has to be called with Self_ID's ATCB write-locked. + -- May temporariliy release the lock. + pragma Inline (Poll_Base_Priority_Change); + + ---------------------- + -- Task Lock/Unlock -- + ---------------------- + + procedure Task_Lock (Self_ID : Task_ID); + procedure Task_Unlock (Self_ID : Task_ID); + -- These are versions of Lock_Task and Unlock_Task created for use + -- within the GNARL. + + procedure Final_Task_Unlock (Self_ID : Task_ID); + -- This version is only for use in Terminate_Task, when the task + -- is relinquishing further rights to its own ATCB. + -- There is a very interesting potential race condition there, where + -- the old task may run concurrently with a new task that is allocated + -- the old tasks (now reused) ATCB. The critical thing here is to + -- not make any reference to the ATCB after the lock is released. + -- See also comments on Terminate_Task and Unlock. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State); + pragma Inline (Wakeup_Entry_Caller); + -- This is called at the end of service of an entry call, + -- to abort the caller if he is in an abortable part, and + -- to wake up the caller if he is on Entry_Caller_Sleep. + -- Call it holding the lock of Entry_Call.Self. + -- + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + -- + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) + -- to complete. + -- + -- Asynchronous_Call: + -- The caller may be executing in the abortable part o + -- an async. select, or on a time delay, + -- if Entry_Call.State >= Was_Abortable. + + procedure Locked_Abort_To_Level + (Self_ID : Task_ID; + T : Task_ID; + L : ATC_Level); + pragma Inline (Locked_Abort_To_Level); + -- Abort a task to a specified ATC level. + -- Call this only with T locked. + +end System.Tasking.Initialization; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb new file mode 100644 index 00000000000..dcab023fdc5 --- /dev/null +++ b/gcc/ada/s-taskin.adb @@ -0,0 +1,181 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.38 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Task_Primitives.Operations; +-- used for Self + +with Unchecked_Deallocation; +-- To recover from failure of ATCB initialization. + +with System.Storage_Elements; +-- Needed for initializing Stack_Info.Size + +with System.Parameters; +-- Used for Adjust_Storage_Size + +package body System.Tasking is + + package STPO renames System.Task_Primitives.Operations; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames STPO.Self; + + --------------------- + -- Initialize_ATCB -- + --------------------- + + -- Call this only with abort deferred and holding All_Tasks_L. + + procedure Initialize_ATCB + (Self_ID : Task_ID; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_ID; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + T : in out Task_ID; + Success : out Boolean) is + begin + T.Common.State := Unactivated; + + -- Initialize T.Common.LL + + STPO.Initialize_TCB (T, Success); + + if not Success then + Free (T); + return; + end if; + + T.Common.Parent := Parent; + T.Common.Base_Priority := Base_Priority; + T.Common.Current_Priority := 0; + T.Common.Call := null; + T.Common.Task_Arg := Task_Arg; + T.Common.Task_Entry_Point := Task_Entry_Point; + T.Common.Activator := Self_ID; + T.Common.Wait_Count := 0; + T.Common.Elaborated := Elaborated; + T.Common.Activation_Failed := False; + T.Common.Task_Info := Task_Info; + + if T.Common.Parent = null then + -- For the environment task, the adjusted stack size is + -- meaningless. For example, an unspecified Stack_Size means + -- that the stack size is determined by the environment, or + -- can grow dynamically. The Stack_Checking algorithm + -- therefore needs to use the requested size, or 0 in + -- case of an unknown size. + + T.Common.Compiler_Data.Pri_Stack_Info.Size := + Storage_Elements.Storage_Offset (Stack_Size); + + else + T.Common.Compiler_Data.Pri_Stack_Info.Size := + Storage_Elements.Storage_Offset + (Parameters.Adjust_Storage_Size (Stack_Size)); + end if; + + -- Link the task into the list of all tasks. + + T.Common.All_Tasks_Link := All_Tasks_List; + All_Tasks_List := T; + end Initialize_ATCB; + + Main_Task_Image : aliased String := "main_task"; + -- Declare a global variable to avoid allocating dynamic memory. + + Main_Priority : Priority; + pragma Import (C, Main_Priority, "__gl_main_priority"); + + ---------------------------- + -- Tasking Initialization -- + ---------------------------- + + -- This block constitutes the first part of the initialization of the + -- GNARL. This includes creating data structures to make the initial thread + -- into the environment task. The last part of the initialization is done + -- in System.Tasking.Initialization or System.Tasking.Restricted.Stages. + -- All the initializations used to be in Tasking.Initialization, but this + -- is no longer possible with the run time simplification (including + -- optimized PO and the restricted run time) since one cannot rely on + -- System.Tasking.Initialization being present, as was done before. + +begin + declare + T : Task_ID; + Success : Boolean; + Base_Priority : Any_Priority; + + begin + -- Initialize Environment Task + + if Main_Priority = Unspecified_Priority then + Base_Priority := Default_Priority; + else + Base_Priority := Main_Priority; + end if; + + Success := True; + T := STPO.New_ATCB (0); + Initialize_ATCB + (null, null, Null_Address, Null_Task, null, Base_Priority, + Task_Info.Unspecified_Task_Info, 0, T, Success); + pragma Assert (Success); + + STPO.Initialize (T); + STPO.Set_Priority (T, T.Common.Base_Priority); + T.Common.State := Runnable; + T.Common.Task_Image := Main_Task_Image'Unrestricted_Access; + + -- Only initialize the first element since others are not relevant + -- in ravenscar mode. Rest of the initialization is done in Init_RTS. + + T.Entry_Calls (1).Self := T; + end; +end System.Tasking; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads new file mode 100644 index 00000000000..de9fe568b98 --- /dev/null +++ b/gcc/ada/s-taskin.ads @@ -0,0 +1,983 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.89 $ +-- -- +-- Copyright (C) 1992-2001, 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 provides necessary type definitions for compiler interface. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; +-- Used for: Exception_Id + +with System.Parameters; +-- used for Size_Type + +with System.Task_Info; +-- used for Task_Info_Type, Task_Image_Type + +with System.Soft_Links; +-- used for TSD + +with System.Task_Primitives; +-- used for Private_Data +-- Lock (in System.Tasking.Protected_Objects) + +with Unchecked_Conversion; + +package System.Tasking is + + -- ------------------- + -- -- Locking Rules -- + -- ------------------- + -- + -- The following rules must be followed at all times, to prevent + -- deadlock and generally ensure correct operation of locking. + -- + -- . Never lock a lock unless abort is deferred. + -- + -- . Never undefer abort while holding a lock. + -- + -- . Overlapping critical sections must be properly nested, + -- and locks must be released in LIFO order. + -- e.g., the following is not allowed: + -- + -- Lock (X); + -- ... + -- Lock (Y); + -- ... + -- Unlock (X); + -- ... + -- Unlock (Y); + -- + -- Locks with lower (smaller) level number cannot be locked + -- while holding a lock with a higher level number. (The level + -- number is the number at the left.) + -- + -- 1. System.Tasking.PO_Simple.Protection.L (any PO lock) + -- 2. System.Tasking.Initialization.Global_Task_Lock (in body) + -- 3. System.Tasking.Task_Attributes.All_Attrs_L + -- 4. System.Task_Primitives.Operations.All_Tasks_L + -- 5. System.Interrupts.L (in body) + -- 6. System.Tasking.Ada_Task_Control_Block.LL.L (any TCB lock) + -- + -- Clearly, there can be no circular chain of hold-and-wait + -- relationships involving locks in different ordering levels. + -- + -- We used to have Global_Task_Lock before Protection.L but this was + -- clearly wrong since there can be calls to "new" inside protected + -- operations. The new ordering prevents these failures. + -- + -- Sometime we need to hold two ATCB locks at the same time. To allow + -- us to order the locking, each ATCB is given a unique serial + -- number. If one needs to hold locks on several ATCBs at once, + -- the locks with lower serial numbers must be locked first. + -- + -- We don't always need to check the serial numbers, since + -- the serial numbers are assigned sequentially, and so: + -- + -- . The parent of a task always has a lower serial number. + -- . The activator of a task always has a lower serial number. + -- . The environment task has a lower serial number than any other task. + -- . If the activator of a task is different from the task's parent, + -- the parent always has a lower serial number than the activator. + -- + -- For interrupt-handler state, we have a special locking rule. + -- See System.Interrupts (spec) for explanation. + + --------------------------------- + -- Task_ID related definitions -- + --------------------------------- + + type Ada_Task_Control_Block; + + type Task_ID is access all Ada_Task_Control_Block; + + Null_Task : constant Task_ID; + + type Task_List is array (Positive range <>) of Task_ID; + + function Self return Task_ID; + pragma Inline (Self); + -- This is the compiler interface version of this function. Do not call + -- from the run-time system. + + function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID); + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ----------------------- + -- Enumeration types -- + ----------------------- + + type Task_States is + (Unactivated, + -- Task has been created but has not been activated. + -- It cannot be executing. + + -- Active states + -- For all states from here down, the task has been activated. + -- For all states from here down, except for Terminated, the task + -- may be executing. + -- Activator = null iff it has not yet completed activating. + + -- For all states from here down, + -- the task has been activated, and may be executing. + + Runnable, + -- Task is not blocked for any reason known to Ada. + -- (It may be waiting for a mutex, though.) + -- It is conceptually "executing" in normal mode. + + Terminated, + -- The task is terminated, in the sense of ARM 9.3 (5). + -- Any dependents that were waiting on terminate + -- alternatives have been awakened and have terminated themselves. + + Activator_Sleep, + -- Task is waiting for created tasks to complete activation. + + Acceptor_Sleep, + -- Task is waiting on an accept or selective wait statement. + + Entry_Caller_Sleep, + -- Task is waiting on an entry call. + + Async_Select_Sleep, + -- Task is waiting to start the abortable part of an + -- asynchronous select statement. + + Delay_Sleep, + -- Task is waiting on a select statement with only a delay + -- alternative open. + + Master_Completion_Sleep, + -- Master completion has two phases. + -- In Phase 1 the task is sleeping in Complete_Master + -- having completed a master within itself, + -- and is waiting for the tasks dependent on that master to become + -- terminated or waiting on a terminate Phase. + + Master_Phase_2_Sleep, + -- In Phase 2 the task is sleeping in Complete_Master + -- waiting for tasks on terminate alternatives to finish + -- terminating. + + -- The following are special uses of sleep, for server tasks + -- within the run-time system. + + Interrupt_Server_Idle_Sleep, + Interrupt_Server_Blocked_Interrupt_Sleep, + Timer_Server_Sleep, + AST_Server_Sleep, + + Asynchronous_Hold, + -- The task has been held by Asynchronous_Task_Control.Hold_Task + + Interrupt_Server_Blocked_On_Event_Flag + -- The task has been blocked on a system call waiting for the + -- completion event. + ); + + type Call_Modes is + (Simple_Call, Conditional_Call, Asynchronous_Call, Timed_Call); + + type Select_Modes is (Simple_Mode, Else_Mode, Terminate_Mode, Delay_Mode); + + subtype Delay_Modes is Integer; + + ------------------------------- + -- Entry related definitions -- + ------------------------------- + + Null_Entry : constant := 0; + + Max_Entry : constant := Integer'Last; + + Interrupt_Entry : constant := -2; + + Cancelled_Entry : constant := -1; + + type Entry_Index is range Interrupt_Entry .. Max_Entry; + + Null_Task_Entry : constant := Null_Entry; + + Max_Task_Entry : constant := Max_Entry; + + type Task_Entry_Index is new Entry_Index + range Null_Task_Entry .. Max_Task_Entry; + + type Entry_Call_Record; + + type Entry_Call_Link is access all Entry_Call_Record; + + type Entry_Queue is record + Head : Entry_Call_Link; + Tail : Entry_Call_Link; + end record; + + type Task_Entry_Queue_Array is + array (Task_Entry_Index range <>) of Entry_Queue; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + type Entry_Call_State is + (Never_Abortable, + -- the call is not abortable, and never can be + + Not_Yet_Abortable, + -- the call is not abortable, but may become so + + Was_Abortable, + -- the call is not abortable, but once was + + Now_Abortable, + -- the call is abortable + + Done, + -- the call has been completed + + Cancelled + -- the call was asynchronous, and was cancelled + ); + + -- Never_Abortable is used for calls that are made in a abort + -- deferred region (see ARM 9.8(5-11), 9.8 (20)). + -- Such a call is never abortable. + + -- The Was_ vs. Not_Yet_ distinction is needed to decide whether it + -- is OK to advance into the abortable part of an async. select stmt. + -- That is allowed iff the mode is Now_ or Was_. + + -- Done indicates the call has been completed, without cancellation, + -- or no call has been made yet at this ATC nesting level, + -- and so aborting the call is no longer an issue. + -- Completion of the call does not necessarily indicate "success"; + -- the call may be returning an exception if Exception_To_Raise is + -- non-null. + + -- Cancelled indicates the call was cancelled, + -- and so aborting the call is no longer an issue. + + -- The call is on an entry queue unless + -- State >= Done, in which case it may or may not be still Onqueue. + + -- Please do not modify the order of the values, without checking + -- all uses of this type. We rely on partial "monotonicity" of + -- Entry_Call_Record.State to avoid locking when we access this + -- value for certain tests. In particular: + + -- 1) Once State >= Done, we can rely that the call has been + -- completed. If State >= Done, it will not + -- change until the task does another entry call at this level. + + -- 2) Once State >= Was_Abortable, we can rely that the call has + -- been queued abortably at least once, and so the check for + -- whether it is OK to advance to the abortable part of an + -- async. select statement does not need to lock anything. + + type Restricted_Entry_Call_Record is record + Self : Task_ID; + -- ID of the caller + + Mode : Call_Modes; + + State : Entry_Call_State; + pragma Atomic (State); + -- Indicates part of the state of the call. + -- Protection: + -- If the call is not on a queue, it should + -- only be accessed by Self, and Self does not need any + -- lock to modify this field. + -- Once the call is on a queue, the value should be + -- something other than Done unless it is cancelled, and access is + -- controller by the "server" of the queue -- i.e., the lock + -- of Checked_To_Protection (Call_Target) + -- if the call record is on the queue of a PO, or the lock + -- of Called_Target if the call is on the queue of a task. + -- See comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler. + + Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + end record; + pragma Suppress_Initialization (Restricted_Entry_Call_Record); + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Activation_Chain is limited private; + + type Activation_Chain_Access is access all Activation_Chain; + + type Task_Procedure_Access is access procedure (Arg : System.Address); + + type Access_Boolean is access all Boolean; + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + -- Notes on protection (synchronization) of TRTS data structures. + + -- Any field of the TCB can be written by the activator of a task when the + -- task is created, since no other task can access the new task's + -- state until creation is complete. + + -- The protection for each field is described in a comment starting with + -- "Protection:". + + -- When a lock is used to protect an ATCB field, this lock is simply named. + + -- Some protection is described in terms of tasks related to the + -- ATCB being protected. These are: + + -- Self: The task which is controlled by this ATCB. + -- Acceptor: A task accepting a call from Self. + -- Caller: A task calling an entry of Self. + -- Parent: The task executing the master on which Self depends. + -- Dependent: A task dependent on Self. + -- Activator: The task that created Self and initiated its activation. + -- Created: A task created and activated by Self. + + -- Note: The order of the fields is important to implement efficiently + -- tasking support under gdb. + -- Currently gdb relies on the order of the State, Parent, Base_Priority, + -- Task_Image, Call and LL fields. + + ---------------------------------------------------------------------- + -- Common ATCB section -- + -- -- + -- This section is used by all GNARL implementations (regular and -- + -- restricted) -- + ---------------------------------------------------------------------- + + type Common_ATCB is record + State : Task_States; + pragma Atomic (State); + -- Encodes some basic information about the state of a task, + -- including whether it has been activated, whether it is sleeping, + -- and whether it is terminated. + -- Protection: Self.L. + + Parent : Task_ID; + -- The task on which this task depends. + -- See also Master_Level and Master_Within. + + Base_Priority : System.Any_Priority; + -- Base priority, not changed during entry calls, only changed + -- via dynamic priorities package. + -- Protection: Only written by Self, accessed by anyone. + + Current_Priority : System.Any_Priority; + -- Active priority, except that the effects of protected object + -- priority ceilings are not reflected. This only reflects explicit + -- priority changes and priority inherited through task activation + -- and rendezvous. + -- + -- Ada 95 notes: In Ada 95, this field will be transferred to the + -- Priority field of an Entry_Calls component when an entry call + -- is initiated. The Priority of the Entry_Calls component will not + -- change for the duration of the call. The accepting task can + -- use it to boost its own priority without fear of its changing in + -- the meantime. + -- + -- This can safely be used in the priority ordering + -- of entry queues. Once a call is queued, its priority does not + -- change. + -- + -- Since an entry call cannot be made while executing + -- a protected action, the priority of a task will never reflect a + -- priority ceiling change at the point of an entry call. + -- + -- Protection: Only written by Self, and only accessed when Acceptor + -- accepts an entry or when Created activates, at which points Self is + -- suspended. + + Task_Image : System.Task_Info.Task_Image_Type; + -- holds an access to string that provides a readable id for task, + -- built from the variable of which it is a value or component. + + Call : Entry_Call_Link; + -- The entry call that has been accepted by this task. + -- Protection: Self.L. Self will modify this field + -- when Self.Accepting is False, and will not need the mutex to do so. + -- Once a task sets Pending_ATC_Level = 0, no other task can access + -- this field. + + LL : aliased Task_Primitives.Private_Data; + -- Control block used by the underlying low-level tasking + -- service (GNULLI). + -- Protection: This is used only by the GNULLI implementation, which + -- takes care of all of its synchronization. + + Task_Arg : System.Address; + -- The argument to task procedure. Currently unused; this will + -- provide a handle for discriminant information. + -- Protection: Part of the synchronization between Self and + -- Activator. Activator writes it, once, before Self starts + -- executing. Thereafter, Self only reads it. + + Task_Entry_Point : Task_Procedure_Access; + -- Information needed to call the procedure containing the code for + -- the body of this task. + -- Protection: Part of the synchronization between Self and + -- Activator. Activator writes it, once, before Self starts + -- executing. Self reads it, once, as part of its execution. + + Compiler_Data : System.Soft_Links.TSD; + -- Task-specific data needed by the compiler to store + -- per-task structures. + -- Protection: Only accessed by Self. + + All_Tasks_Link : Task_ID; + -- Used to link this task to the list of all tasks in the system. + -- Protection: All_Tasks.L. + + Activation_Link : Task_ID; + -- Used to link this task to a list of tasks to be activated. + -- Protection: Only used by Activator. + + Activator : Task_ID; + -- The task that created this task, either by declaring it as a task + -- object or by executing a task allocator. + -- The value is null iff Self has completed activation. + -- Protection: Set by Activator before Self is activated, and + -- only read and modified by Self after that. + + Wait_Count : Integer; + -- This count is used by a task that is waiting for other tasks. + -- At all other times, the value should be zero. + -- It is used differently in several different states. + -- Since a task cannot be in more than one of these states at the + -- same time, a single counter suffices. + -- Protection: Self.L. + + -- Activator_Sleep + + -- This is the number of tasks that this task is activating, i.e. the + -- children that have started activation but have not completed it. + -- Protection: Self.L and Created.L. Both mutexes must be locked, + -- since Self.Activation_Count and Created.State must be synchronized. + + -- Master_Completion_Sleep (phase 1) + + -- This is the number dependent tasks of a master being + -- completed by Self that are not activated, not terminated, and + -- not waiting on a terminate alternative. + + -- Master_Completion_2_Sleep (phase 2) + + -- This is the count of tasks dependent on a master being + -- completed by Self which are waiting on a terminate alternative. + + Elaborated : Access_Boolean; + -- Pointer to a flag indicating that this task's body has been + -- elaborated. The flag is created and managed by the + -- compiler-generated code. + -- Protection: The field itself is only accessed by Activator. The flag + -- that it points to is updated by Master and read by Activator; access + -- is assumed to be atomic. + + Activation_Failed : Boolean; + -- Set to True if activation of a chain of tasks fails, + -- so that the activator should raise Tasking_Error. + + Task_Info : System.Task_Info.Task_Info_Type; + -- System-specific attributes of the task as specified by the + -- Task_Info pragma. + end record; + + --------------------------------------- + -- Restricted_Ada_Task_Control_Block -- + --------------------------------------- + + -- This type should only be used by the restricted GNARLI and by + -- restricted GNULL implementations to allocate an ATCB (see + -- System.Task_Primitives.Operations.New_ATCB) that will take + -- significantly less memory. + -- Note that the restricted GNARLI should only access fields that are + -- present in the Restricted_Ada_Task_Control_Block structure. + + type Restricted_Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is + record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Entry_Call : aliased Restricted_Entry_Call_Record; + -- Protection: This field is used on entry call "queues" associated + -- with protected objects, and is protected by the protected object + -- lock. + end record; + pragma Suppress_Initialization (Restricted_Ada_Task_Control_Block); + + Interrupt_Manager_ID : Task_ID; + -- This task ID is declared here to break circular dependencies. + -- Also declare Interrupt_Manager_ID after Task_ID is known, to avoid + -- generating unneeded finalization code. + + ----------------------- + -- List of all Tasks -- + ----------------------- + + All_Tasks_List : Task_ID; + -- Global linked list of all tasks. + + ------------------------------------------ + -- Regular (non restricted) definitions -- + ------------------------------------------ + + -------------------------------- + -- Master Related Definitions -- + -------------------------------- + + subtype Master_Level is Integer; + subtype Master_ID is Master_Level; + + -- Normally, a task starts out with internal master nesting level + -- one larger than external master nesting level. It is incremented + -- to one by Enter_Master, which is called in the task body only if + -- the compiler thinks the task may have dependent tasks. It is set to 1 + -- for the environment task, the level 2 is reserved for server tasks of + -- the run-time system (the so called "independent tasks"), and the level + -- 3 is for the library level tasks. + + Environment_Task_Level : constant Master_Level := 1; + Independent_Task_Level : constant Master_Level := 2; + Library_Task_Level : constant Master_Level := 3; + + ------------------------------ + -- Task size, priority info -- + ------------------------------ + + Unspecified_Priority : constant Integer := System.Priority'First - 1; + + Priority_Not_Boosted : constant Integer := System.Priority'First - 1; + -- Definition of Priority actually has to come from the RTS configuration. + + subtype Rendezvous_Priority is Integer + range Priority_Not_Boosted .. System.Any_Priority'Last; + + ------------------------------------ + -- Rendezvous related definitions -- + ------------------------------------ + + No_Rendezvous : constant := 0; + + Max_Select : constant Integer := Integer'Last; + -- RTS-defined + + subtype Select_Index is Integer range No_Rendezvous .. Max_Select; + -- type Select_Index is range No_Rendezvous .. Max_Select; + + subtype Positive_Select_Index is + Select_Index range 1 .. Select_Index'Last; + + type Accept_Alternative is record + Null_Body : Boolean; + S : Task_Entry_Index; + end record; + + type Accept_List is + array (Positive_Select_Index range <>) of Accept_Alternative; + + type Accept_List_Access is access constant Accept_List; + + ----------------------------------- + -- ATC_Level related definitions -- + ----------------------------------- + + Max_ATC_Nesting : constant Natural := 20; + + subtype ATC_Level_Base is Integer range 0 .. Max_ATC_Nesting; + + ATC_Level_Infinity : constant ATC_Level_Base := ATC_Level_Base'Last; + + subtype ATC_Level is ATC_Level_Base range 0 .. ATC_Level_Base'Last - 1; + + subtype ATC_Level_Index is ATC_Level range 1 .. ATC_Level'Last; + + ---------------------------------- + -- Entry_Call_Record definition -- + ---------------------------------- + + type Entry_Call_Record is record + Self : Task_ID; + -- ID of the caller + + Mode : Call_Modes; + + State : Entry_Call_State; + pragma Atomic (State); + -- Indicates part of the state of the call. + -- Protection: + -- If the call is not on a queue, it should + -- only be accessed by Self, and Self does not need any + -- lock to modify this field. + -- Once the call is on a queue, the value should be + -- something other than Done unless it is cancelled, and access is + -- controller by the "server" of the queue -- i.e., the lock + -- of Checked_To_Protection (Call_Target) + -- if the call record is on the queue of a PO, or the lock + -- of Called_Target if the call is on the queue of a task. + -- See comments on type declaration for more details. + + Uninterpreted_Data : System.Address; + -- Data passed by the compiler. + + Exception_To_Raise : Ada.Exceptions.Exception_Id; + -- The exception to raise once this call has been completed without + -- being aborted. + + Prev : Entry_Call_Link; + + Next : Entry_Call_Link; + + Level : ATC_Level; + -- One of Self and Level are redundant in this implementation, since + -- each Entry_Call_Record is at Self.Entry_Calls (Level). Since we must + -- have access to the entry call record to be reading this, we could + -- get Self from Level, or Level from Self. However, this requires + -- non-portable address arithmetic. + + E : Entry_Index; + + Prio : System.Any_Priority; + + -- The above fields are those that there may be some hope of packing. + -- They are gathered together to allow for compilers that lay records + -- out contiguously, to allow for such packing. + + Called_Task : Task_ID; + pragma Atomic (Called_Task); + -- Use for task entry calls. + -- The value is null if the call record is not in use. + -- Conversely, unless State is Done and Onqueue is false, + -- Called_Task points to an ATCB. + -- Protection: Called_Task.L. + + Called_PO : System.Address; + pragma Atomic (Called_PO); + -- Similar to Called_Task but for protected objects. + -- Note that the previous implementation tried to merge both + -- Called_Task and Called_PO but this ended up in many unexpected + -- complications (e.g having to add a magic number in the ATCB, which + -- caused gdb lots of confusion) with no real gain since the Lock_Server + -- implementation still need to loop around chasing for pointer changes + -- even with a single pointer. + + Acceptor_Prev_Call : Entry_Call_Link; + -- For task entry calls only. + + Acceptor_Prev_Priority : Rendezvous_Priority := Priority_Not_Boosted; + -- For task entry calls only. + -- The priority of the most recent prior call being serviced. + -- For protected entry calls, this function should be performed by + -- GNULLI ceiling locking. + + Cancellation_Attempted : Boolean := False; + pragma Atomic (Cancellation_Attempted); + -- Cancellation of the call has been attempted. + -- If it has succeeded, State = Cancelled. + -- ????? + -- Consider merging this into State? + + Requeue_With_Abort : Boolean := False; + -- Temporary to tell caller whether requeue is with abort. + -- ????? + -- Find a better way of doing this. + + Needs_Requeue : Boolean := False; + -- Temporary to tell acceptor of task entry call that + -- Exceptional_Complete_Rendezvous needs to do requeue. + end record; + + ------------------------------------ + -- Task related other definitions -- + ------------------------------------ + + type Access_Address is access all System.Address; + + ---------------------------------------------- + -- Ada_Task_Control_Block (ATCB) definition -- + ---------------------------------------------- + + type Entry_Call_Array is array (ATC_Level_Index) of + aliased Entry_Call_Record; + + D_I_Count : constant := 2; + -- This constant may be adjusted, to allow more Address-sized + -- attributes to be stored directly in the task control block. + + subtype Direct_Index is Integer range 0 .. D_I_Count - 1; + -- Attributes with indices in this range are stored directly in + -- the task control block. Such attributes must be Address-sized. + -- Other attributes will be held in dynamically allocated records + -- chained off of the task control block. + + type Direct_Attribute_Array is + array (Direct_Index) of aliased System.Address; + + type Direct_Index_Vector is mod 2 ** D_I_Count; + -- This is a bit-vector type, used to store information about + -- the usage of the direct attribute fields. + + type Task_Serial_Number is mod 2 ** 64; + -- Used to give each task a unique serial number. + + type Ada_Task_Control_Block (Entry_Num : Task_Entry_Index) is record + Common : Common_ATCB; + -- The common part between various tasking implementations + + Entry_Calls : Entry_Call_Array; + -- An array of entry calls. + -- Protection: The elements of this array are on entry call queues + -- associated with protected objects or task entries, and are protected + -- by the protected object lock or Acceptor.L, respectively. + + New_Base_Priority : System.Any_Priority; + -- New value for Base_Priority (for dynamic priorities package). + -- Protection: Self.L. + + Global_Task_Lock_Nesting : Natural := 0; + -- This is the current nesting level of calls to + -- System.Tasking.Stages.Lock_Task_T. + -- This allows a task to call Lock_Task_T multiple times without + -- deadlocking. A task only locks All_Task_Lock when its + -- All_Tasks_Nesting goes from 0 to 1, and only unlocked when it + -- goes from 1 to 0. + -- Protection: Only accessed by Self. + + Open_Accepts : Accept_List_Access; + -- This points to the Open_Accepts array of accept alternatives passed + -- to the RTS by the compiler-generated code to Selective_Wait. + -- It is non-null iff this task is ready to accept an entry call. + -- Protection: Self.L. + + Chosen_Index : Select_Index; + -- The index in Open_Accepts of the entry call accepted by a selective + -- wait executed by this task. + -- Protection: Written by both Self and Caller. Usually protected + -- by Self.L. However, once the selection is known to have been + -- written it can be accessed without protection. This happens + -- after Self has updated it itself using information from a suspended + -- Caller, or after Caller has updated it and awakened Self. + + Master_of_Task : Master_Level; + -- The task executing the master of this task, and the ID of this task's + -- master (unique only among masters currently active within Parent). + -- Protection: Set by Activator before Self is activated, and + -- read after Self is activated. + + Master_Within : Master_Level; + -- The ID of the master currently executing within this task; that is, + -- the most deeply nested currently active master. + -- Protection: Only written by Self, and only read by Self or by + -- dependents when Self is attempting to exit a master. Since Self + -- will not write this field until the master is complete, the + -- synchronization should be adequate to prevent races. + + Alive_Count : Integer := 0; + -- Number of tasks directly dependent on this task (including itself) + -- that are still "alive", i.e. not terminated. + -- Protection: Self.L. + + Awake_Count : Integer := 0; + -- Number of tasks directly dependent on this task (including itself) + -- still "awake", i.e., are not terminated and not waiting on a + -- terminate alternative. + -- Invariant: Awake_Count <= Alive_Count + -- Protection: Self.L. + + -- beginning of flags + + Aborting : Boolean := False; + pragma Atomic (Aborting); + -- Self is in the process of aborting. While set, prevents multiple + -- abortion signals from being sent by different aborter while abortion + -- is acted upon. This is essential since an aborter which calls + -- Abort_To_Level could set the Pending_ATC_Level to yet a lower level + -- (than the current level), may be preempted and would send the + -- abortion signal when resuming execution. At this point, the abortee + -- may have completed abortion to the proper level such that the + -- signal (and resulting abortion exception) are not handled any more. + -- In other words, the flag prevents a race between multiple aborters + -- and the abortee. + -- Protection: Self.L. + + ATC_Hack : Boolean := False; + pragma Atomic (ATC_Hack); + -- ????? + -- Temporary fix, to allow Undefer_Abort to reset Aborting in the + -- handler for Abort_Signal that encloses an async. entry call. + -- For the longer term, this should be done via code in the + -- handler itself. + + Callable : Boolean := True; + -- It is OK to call entries of this task. + + Dependents_Aborted : Boolean := False; + -- This is set to True by whichever task takes responsibility + -- for aborting the dependents of this task. + -- Protection: Self.L. + + Interrupt_Entry : Boolean := False; + -- Indicates if one or more Interrupt Entries are attached to + -- the task. This flag is needed for cleaning up the Interrupt + -- Entry bindings. + + Pending_Action : Boolean := False; + -- Unified flag indicating some action needs to be take when abort + -- next becomes undeferred. Currently set if: + -- . Pending_Priority_Change is set + -- . Pending_ATC_Level is changed + -- . Requeue involving POs + -- (Abortable field may have changed and the Wait_Until_Abortable + -- has to recheck the abortable status of the call.) + -- . Exception_To_Raise is non-null + -- Protection: Self.L. + -- This should never be reset back to False outside of the + -- procedure Do_Pending_Action, which is called by Undefer_Abort. + -- It should only be set to True by Set_Priority and Abort_To_Level. + + Pending_Priority_Change : Boolean := False; + -- Flag to indicate pending priority change (for dynamic priorities + -- package). The base priority is updated on the next abortion + -- completion point (aka. synchronization point). + -- Protection: Self.L. + + Terminate_Alternative : Boolean := False; + -- Task is accepting Select with Terminate Alternative. + -- Protection: Self.L. + + -- end of flags + + -- beginning of counts + + ATC_Nesting_Level : ATC_Level := 1; + -- The dynamic level of ATC nesting (currently executing nested + -- asynchronous select statements) in this task. + -- Protection: Self_ID.L. + -- Only Self reads or updates this field. + -- Decrementing it deallocates an Entry_Calls component, and care must + -- be taken that all references to that component are eliminated + -- before doing the decrement. This in turn will require locking + -- a protected object (for a protected entry call) or the Acceptor's + -- lock (for a task entry call). + -- No other task should attempt to read or modify this value. + + Deferral_Level : Natural := 1; + -- This is the number of times that Defer_Abortion has been called by + -- this task without a matching Undefer_Abortion call. Abortion is + -- only allowed when this zero. + -- It is initially 1, to protect the task at startup. + -- Protection: Only updated by Self; access assumed to be atomic. + + Pending_ATC_Level : ATC_Level_Base := ATC_Level_Infinity; + -- The ATC level to which this task is currently being aborted. + -- If the value is zero, the entire task has "completed". + -- That may be via abort, exception propagation, or normal exit. + -- If the value is ATC_Level_Infinity, the task is not being + -- aborted to any level. + -- If the value is positive, the task has not completed. + -- This should ONLY be modified by + -- Abort_To_Level and Exit_One_ATC_Level. + -- Protection: Self.L. + + Serial_Number : Task_Serial_Number; + -- A growing number to provide some way to check locking + -- rules/ordering. + + Known_Tasks_Index : Integer := -1; + -- Index in the System.Tasking.Debug.Known_Tasks array. + + User_State : Integer := 0; + -- user-writeable location, for use in debugging tasks; + -- debugger can display this value to show where the task currently + -- is, in user terms + + Direct_Attributes : Direct_Attribute_Array; + -- for task attributes that have same size as Address + Is_Defined : Direct_Index_Vector := 0; + -- bit I is 1 iff Direct_Attributes (I) is defined + Indirect_Attributes : Access_Address; + -- a pointer to chain of records for other attributes that + -- are not address-sized, including all tagged types. + + Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); + -- An array of task entry queues. + -- Protection: Self.L. Once a task has set Self.Stage to Completing, it + -- has exclusive access to this field. + end record; + pragma Volatile (Ada_Task_Control_Block); + + --------------------- + -- Initialize_ATCB -- + --------------------- + + procedure Initialize_ATCB + (Self_ID : Task_ID; + Task_Entry_Point : Task_Procedure_Access; + Task_Arg : System.Address; + Parent : Task_ID; + Elaborated : Access_Boolean; + Base_Priority : System.Any_Priority; + Task_Info : System.Task_Info.Task_Info_Type; + Stack_Size : System.Parameters.Size_Type; + T : in out Task_ID; + Success : out Boolean); + -- Initialize fields of a TCB and link into global TCB structures + -- Call this only with abort deferred and holding All_Tasks_L. + +private + + Null_Task : constant Task_ID := null; + + type Activation_Chain is record + T_ID : Task_ID; + end record; + pragma Volatile (Activation_Chain); + + -- Activation_chain is an in-out parameter of initialization procedures + -- and it must be passed by reference because the init_proc may terminate + -- abnormally after creating task components, and these must be properly + -- registered for removal (Expunge_Unactivated_Tasks). + +end System.Tasking; diff --git a/gcc/ada/s-tasque.adb b/gcc/ada/s-tasque.adb new file mode 100644 index 00000000000..19533476073 --- /dev/null +++ b/gcc/ada/s-tasque.adb @@ -0,0 +1,632 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This version of the body implements queueing policy according to the +-- policy specified by the pragma Queuing_Policy. When no such pragma +-- is specified FIFO policy is used as default. + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock + +with System.Tasking.Initialization; +-- used for Wakeup_Entry_Caller + +package body System.Tasking.Queuing is + + use System.Task_Primitives.Operations; + use System.Tasking.Protected_Objects; + use System.Tasking.Protected_Objects.Entries; + + procedure Wakeup_Entry_Caller + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + renames Initialization.Wakeup_Entry_Caller; + + -- Entry Queues implemented as doubly linked list. + + Queuing_Policy : Character; + pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); + + Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; + + procedure Send_Program_Error + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + -- Raise Program_Error in the caller of the specified entry call + + function Check_Queue (E : Entry_Queue) return Boolean; + -- Check the validity of E. + -- Return True if E is valid, raise Assert_Failure if assertions are + -- enabled and False otherwise. + + ----------------------------- + -- Broadcast_Program_Error -- + ----------------------------- + + procedure Broadcast_Program_Error + (Self_ID : Task_ID; + Object : Protection_Entries_Access; + Pending_Call : Entry_Call_Link) + is + Entry_Call : Entry_Call_Link; + + begin + if Pending_Call /= null then + Send_Program_Error (Self_ID, Pending_Call); + end if; + + for E in Object.Entry_Queues'Range loop + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + + while Entry_Call /= null loop + pragma Assert (Entry_Call.Mode /= Conditional_Call); + + Send_Program_Error (Self_ID, Entry_Call); + Dequeue_Head (Object.Entry_Queues (E), Entry_Call); + end loop; + end loop; + end Broadcast_Program_Error; + + ----------------- + -- Check_Queue -- + ----------------- + + function Check_Queue (E : Entry_Queue) return Boolean is + Valid : Boolean := True; + C, Prev : Entry_Call_Link; + + begin + if E.Head = null then + if E.Tail /= null then + Valid := False; + pragma Assert (Valid); + end if; + else + if E.Tail = null + or else E.Tail.Next /= E.Head + then + Valid := False; + pragma Assert (Valid); + + else + C := E.Head; + + loop + Prev := C; + C := C.Next; + + if C = null then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + if Prev /= C.Prev then + Valid := False; + pragma Assert (Valid); + exit; + end if; + + exit when C = E.Head; + end loop; + + if Prev /= E.Tail then + Valid := False; + pragma Assert (Valid); + end if; + end if; + end if; + + return Valid; + end Check_Queue; + + ------------------- + -- Count_Waiting -- + ------------------- + + -- Return number of calls on the waiting queue of E + + function Count_Waiting (E : in Entry_Queue) return Natural is + Count : Natural; + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + + Count := 0; + + if E.Head /= null then + Temp := E.Head; + + loop + Count := Count + 1; + exit when E.Tail = Temp; + Temp := Temp.Next; + end loop; + end if; + + return Count; + end Count_Waiting; + + ------------- + -- Dequeue -- + ------------- + + -- Dequeue call from entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- If empty queue, simply return + + if E.Head = null then + return; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call.Next; + Call.Next.Prev := Call.Prev; + + if E.Head = Call then + + -- Case of one element + + if E.Tail = Call then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + E.Head := Call.Next; + end if; + + elsif E.Tail = Call then + E.Tail := Call.Prev; + end if; + + -- Successfully dequeued + + Call.Prev := null; + Call.Next := null; + pragma Assert (Check_Queue (E)); + end Dequeue; + + ------------------ + -- Dequeue_Call -- + ------------------ + + procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Dequeue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Dequeue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Dequeue_Call; + + ------------------ + -- Dequeue_Head -- + ------------------ + + -- Remove and return the head of entry_queue E + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link) + is + Temp : Entry_Call_Link; + + begin + pragma Assert (Check_Queue (E)); + -- If empty queue, return null pointer + + if E.Head = null then + Call := null; + return; + end if; + + Temp := E.Head; + + -- Case of one element + + if E.Head = E.Tail then + E.Head := null; + E.Tail := null; + + -- More than one element + + else + pragma Assert (Temp /= null); + pragma Assert (Temp.Next /= null); + pragma Assert (Temp.Prev /= null); + + E.Head := Temp.Next; + Temp.Prev.Next := Temp.Next; + Temp.Next.Prev := Temp.Prev; + end if; + + -- Successfully dequeued + + Temp.Prev := null; + Temp.Next := null; + Call := Temp; + pragma Assert (Check_Queue (E)); + end Dequeue_Head; + + ------------- + -- Enqueue -- + ------------- + + -- Enqueue call at the end of entry_queue E, for FIFO queuing policy. + -- Enqueue call priority ordered, FIFO at same priority level, for + -- Priority queuing policy. + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is + Temp : Entry_Call_Link := E.Head; + + begin + pragma Assert (Check_Queue (E)); + pragma Assert (Call /= null); + + -- Priority Queuing + + if Priority_Queuing then + if Temp = null then + Call.Prev := Call; + Call.Next := Call; + E.Head := Call; + E.Tail := Call; + + else + loop + -- Find the entry that the new guy should precede + + exit when Call.Prio > Temp.Prio; + Temp := Temp.Next; + + if Temp = E.Head then + Temp := null; + exit; + end if; + end loop; + + if Temp = null then + -- Insert at tail + + Call.Prev := E.Tail; + Call.Next := E.Head; + E.Tail := Call; + + else + Call.Prev := Temp.Prev; + Call.Next := Temp; + + -- Insert at head + + if Temp = E.Head then + E.Head := Call; + end if; + end if; + + pragma Assert (Call.Prev /= null); + pragma Assert (Call.Next /= null); + + Call.Prev.Next := Call; + Call.Next.Prev := Call; + end if; + + pragma Assert (Check_Queue (E)); + return; + end if; + + -- FIFO Queuing + + if E.Head = null then + E.Head := Call; + else + E.Tail.Next := Call; + Call.Prev := E.Tail; + end if; + + E.Head.Prev := Call; + E.Tail := Call; + Call.Next := E.Head; + pragma Assert (Check_Queue (E)); + end Enqueue; + + ------------------ + -- Enqueue_Call -- + ------------------ + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is + Called_PO : Protection_Entries_Access; + + begin + pragma Assert (Entry_Call /= null); + + if Entry_Call.Called_Task /= null then + Enqueue + (Entry_Call.Called_Task.Entry_Queues + (Task_Entry_Index (Entry_Call.E)), + Entry_Call); + + else + Called_PO := To_Protection (Entry_Call.Called_PO); + Enqueue (Called_PO.Entry_Queues + (Protected_Entry_Index (Entry_Call.E)), + Entry_Call); + end if; + end Enqueue_Call; + + ---------- + -- Head -- + ---------- + + -- Return the head of entry_queue E + + function Head (E : in Entry_Queue) return Entry_Call_Link is + begin + pragma Assert (Check_Queue (E)); + return E.Head; + end Head; + + ------------- + -- Onqueue -- + ------------- + + -- Return True if Call is on any entry_queue at all + + function Onqueue (Call : Entry_Call_Link) return Boolean is + begin + pragma Assert (Call /= null); + + -- Utilize the fact that every queue is circular, so if Call + -- is on any queue at all, Call.Next must NOT be null. + + return Call.Next /= null; + end Onqueue; + + -------------------------------- + -- Requeue_Call_With_New_Prio -- + -------------------------------- + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is + begin + pragma Assert (Entry_Call /= null); + + -- Perform a queue reordering only when the policy being used is the + -- Priority Queuing. + + if Priority_Queuing then + if Onqueue (Entry_Call) then + Dequeue_Call (Entry_Call); + Entry_Call.Prio := Prio; + Enqueue_Call (Entry_Call); + end if; + end if; + end Requeue_Call_With_New_Prio; + + --------------------------------- + -- Select_Protected_Entry_Call -- + --------------------------------- + + -- Select an entry of a protected object. Selection depends on the + -- queuing policy being used. + + procedure Select_Protected_Entry_Call + (Self_ID : Task_ID; + Object : Protection_Entries_Access; + Call : out Entry_Call_Link) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Protected_Entry_Index; + + begin + Entry_Call := null; + + begin + if Priority_Queuing then + + -- Priority queuing + + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null and then + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + if (Entry_Call = null or else + Entry_Call.Prio < Temp_Call.Prio) + then + Entry_Call := Temp_Call; + Entry_Index := J; + end if; + end if; + end loop; + + else + -- FIFO queuing + + for J in Object.Entry_Queues'Range loop + Temp_Call := Head (Object.Entry_Queues (J)); + + if Temp_Call /= null and then + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, J)). + Barrier (Object.Compiler_Info, J) + then + Entry_Call := Temp_Call; + Entry_Index := J; + exit; + end if; + end loop; + end if; + + exception + when others => + Broadcast_Program_Error (Self_ID, Object, null); + end; + + -- If a call was selected, dequeue it and return it for service. + + if Entry_Call /= null then + Temp_Call := Entry_Call; + Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call); + pragma Assert (Temp_Call = Entry_Call); + end if; + + Call := Entry_Call; + end Select_Protected_Entry_Call; + + ---------------------------- + -- Select_Task_Entry_Call -- + ---------------------------- + + -- Select an entry for rendezvous. Selection depends on the queuing policy + -- being used. + + procedure Select_Task_Entry_Call + (Acceptor : Task_ID; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean) + is + Entry_Call : Entry_Call_Link; + Temp_Call : Entry_Call_Link; + Entry_Index : Task_Entry_Index; + Temp_Entry : Task_Entry_Index; + + begin + Open_Alternative := False; + Entry_Call := null; + + if Priority_Queuing then + + -- Priority Queuing + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null and then + (Entry_Call = null or else + Entry_Call.Prio < Temp_Call.Prio) + + then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + end if; + end if; + end loop; + + else + -- FIFO Queuing + + for J in Open_Accepts'Range loop + Temp_Entry := Open_Accepts (J).S; + + if Temp_Entry /= Null_Task_Entry then + Open_Alternative := True; + Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + + if Temp_Call /= null then + Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); + Entry_Index := Temp_Entry; + Selection := J; + exit; + end if; + end if; + end loop; + end if; + + if Entry_Call = null then + Selection := No_Rendezvous; + + else + Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); + + -- Guard is open + end if; + + Call := Entry_Call; + end Select_Task_Entry_Call; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + Caller : Task_ID; + + begin + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + Write_Lock (Caller); + Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + Unlock (Caller); + end Send_Program_Error; + +end System.Tasking.Queuing; diff --git a/gcc/ada/s-tasque.ads b/gcc/ada/s-tasque.ads new file mode 100644 index 00000000000..9ee56095c0e --- /dev/null +++ b/gcc/ada/s-tasque.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . Q U E U I N G -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.21 $ +-- -- +-- Copyright (C) 1991-1998 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.Tasking.Protected_Objects.Entries; + +package System.Tasking.Queuing is + + package POE renames System.Tasking.Protected_Objects.Entries; + + procedure Broadcast_Program_Error + (Self_ID : Task_ID; + Object : POE.Protection_Entries_Access; + Pending_Call : Entry_Call_Link); + -- Raise Program_Error in all tasks calling the protected entries + -- of Object. The exception will not be raised immediately for + -- the calling task; it will be deferred until it calls + -- Raise_Pending_Exception. + + procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link); + -- Enqueue Call at the end of entry_queue E + + procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link); + -- Dequeue Call from entry_queue E + + function Head (E : in Entry_Queue) return Entry_Call_Link; + -- Return the head of entry_queue E + pragma Inline (Head); + + procedure Dequeue_Head + (E : in out Entry_Queue; + Call : out Entry_Call_Link); + -- Remove and return the head of entry_queue E + + function Onqueue (Call : Entry_Call_Link) return Boolean; + -- Return True if Call is on any entry_queue at all + pragma Inline (Onqueue); + + function Count_Waiting (E : in Entry_Queue) return Natural; + -- Return number of calls on the waiting queue of E + + procedure Select_Task_Entry_Call + (Acceptor : Task_ID; + Open_Accepts : Accept_List_Access; + Call : out Entry_Call_Link; + Selection : out Select_Index; + Open_Alternative : out Boolean); + -- Select an entry for rendezvous. On exit: + -- Call will contain a pointer to the entry call record selected; + -- Selection will contain the index of the alternative selected + -- Open_Alternative will be True if there were any open alternatives + + procedure Select_Protected_Entry_Call + (Self_ID : Task_ID; + Object : POE.Protection_Entries_Access; + Call : out Entry_Call_Link); + -- Select an entry of a protected object + + procedure Enqueue_Call (Entry_Call : Entry_Call_Link); + procedure Dequeue_Call (Entry_Call : Entry_Call_Link); + -- Enqueue (dequeue) the call to (from) whatever server they are + -- calling, whether a task or a protected object. + + procedure Requeue_Call_With_New_Prio + (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority); + -- Change Priority of the call and re insert to the queue when priority + -- queueing is in effect. When FIFO is inforced, this routine + -- should not have any effect. + +end System.Tasking.Queuing; diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb new file mode 100644 index 00000000000..516cee0fd2e --- /dev/null +++ b/gcc/ada/s-tasren.adb @@ -0,0 +1,1815 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.101 $ +-- -- +-- 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.Exceptions; +-- Used for Exception_ID +-- Null_Id +-- Save_Occurrence +-- Raise_Exception + +with System.Task_Primitives.Operations; +-- used for Get_Priority +-- Set_Priority +-- Write_Lock +-- Unlock +-- Sleep +-- Wakeup +-- Timed_Sleep + +with System.Tasking.Entry_Calls; +-- Used for Wait_For_Completion +-- Wait_For_Completion_With_Timeout +-- Wait_Until_Abortable + +with System.Tasking.Initialization; +-- used for Defer_Abort +-- Undefer_Abort +-- Poll_Base_Priority_Change + +with System.Tasking.Queuing; +-- used for Enqueue +-- Dequeue_Head +-- Select_Task_Entry_Call +-- Count_Waiting + +with System.Tasking.Utilities; +-- used for Check_Exception +-- Make_Passive +-- Wakeup_Entry_Caller + +with System.Tasking.Protected_Objects.Operations; +-- used for PO_Do_Or_Queue +-- PO_Service_Entries +-- Lock_Entries +-- Unlock_Entries + +with System.Tasking.Debug; +-- used for Trace + +package body System.Tasking.Rendezvous is + + package STPO renames System.Task_Primitives.Operations; + package POO renames System.Tasking.Protected_Objects.Operations; + package POE renames System.Tasking.Protected_Objects.Entries; + + use System.Task_Primitives; + use System.Task_Primitives.Operations; + + type Select_Treatment is ( + Accept_Alternative_Selected, -- alternative with non-null body + Accept_Alternative_Completed, -- alternative with null body + Else_Selected, + Terminate_Selected, + Accept_Alternative_Open, + No_Alternative_Open); + + Default_Treatment : constant array (Select_Modes) of Select_Treatment := + (Simple_Mode => No_Alternative_Open, + Else_Mode => Else_Selected, + Terminate_Mode => Terminate_Selected, + Delay_Mode => No_Alternative_Open); + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Local_Defer_Abort (Self_Id : Task_ID) renames + System.Tasking.Initialization.Defer_Abort_Nestable; + + procedure Local_Undefer_Abort (Self_Id : Task_ID) renames + System.Tasking.Initialization.Undefer_Abort_Nestable; + + -- Florist defers abort around critical sections that + -- make entry calls to the Interrupt_Manager task, which + -- violates the general rule about top-level runtime system + -- calls from abort-deferred regions. It is not that this is + -- unsafe, but when it occurs in "normal" programs it usually + -- means either the user is trying to do a potentially blocking + -- operation from within a protected object, or there is a + -- runtime system/compiler error that has failed to undefer + -- an earlier abort deferral. Thus, for debugging it may be + -- wise to modify the above renamings to the non-nestable forms. + + procedure Boost_Priority + (Call : Entry_Call_Link; + Acceptor : Task_ID); + pragma Inline (Boost_Priority); + -- Call this only with abort deferred and holding lock of Acceptor. + + procedure Call_Synchronous + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + pragma Inline (Call_Synchronous); + -- This call is used to make a simple or conditional entry call. + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_ID); + pragma Inline (Setup_For_Rendezvous_With_Body); + -- Call this only with abort deferred and holding lock of Acceptor. + -- When a rendezvous selected (ready for rendezvous) we need to save + -- privious caller and adjust the priority. Also we need to make + -- this call not Abortable (Cancellable) since the rendezvous has + -- already been started. + + function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean; + pragma Inline (Is_Entry_Open); + -- Call this only with abort deferred and holding lock of T. + + procedure Wait_For_Call (Self_Id : Task_ID); + pragma Inline (Wait_For_Call); + -- Call this only with abort deferred and holding lock of Self_Id. + -- An accepting task goes into Sleep by calling this routine + -- waiting for a call from the caller or waiting for an abortion. + -- Make sure Self_Id is locked before calling this routine. + + ----------------- + -- Accept_Call -- + ----------------- + + -- Compiler interface only. Do not call from within the RTS. + + -- source: + -- accept E do ...A... end E; + -- expansion: + -- A27b : address; + -- L26b : label + -- begin + -- accept_call (1, A27b); + -- ...A... + -- complete_rendezvous; + -- <<L26b>> + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + + -- The handler for Abort_Signal (*all* others) is to handle the case when + -- the acceptor is aborted between Accept_Call and the corresponding + -- Complete_Rendezvous call. We need to wake up the caller in this case. + + -- See also Selective_Wait + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address) + is + Self_Id : constant Task_ID := STPO.Self; + Caller : Task_ID := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort (Self_Id); + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + -- If someone completed this task, this task should not try to + -- access its pending entry calls or queues in this case, as they + -- are being emptied. Wait for abortion to kill us. + -- ????? + -- Recheck the correctness of the above, now that we have made + -- changes. The logic above seems to be based on the assumption + -- that one task can safely clean up another's in-service accepts. + -- ????? + -- Why do we need to block here in this case? + -- Why not just return and let Undefer_Abort do its work? + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call /= null then + Caller := Entry_Call.Self; + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Uninterpreted_Data := Entry_Call.Uninterpreted_Data; + + else + -- Wait for a caller + + Open_Accepts (1).Null_Body := False; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + -- Wait for normal call + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Pending_ATC_Level >= Self_Id.ATC_Nesting_Level then + Caller := Self_Id.Common.Call.Self; + Uninterpreted_Data := + Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; + end if; + + -- If this task has been aborted, skip the Uninterpreted_Data load + -- (Caller will not be reliable) and fall through to + -- Undefer_Abort which will allow the task to be killed. + -- ????? + -- Perhaps we could do the code anyway, if it has no harm, in order + -- to get better performance for the normal case. + + end if; + + -- Self_Id.Common.Call should already be updated by the Caller + -- On return, we will start the rendezvous. + + STPO.Unlock (Self_Id); + Initialization.Undefer_Abort (Self_Id); + end Accept_Call; + + -------------------- + -- Accept_Trivial -- + -------------------- + + -- Compiler interface only. Do not call from within the RTS. + -- This should only be called when there is no accept body, + -- or the except body is empty. + + -- source: + -- accept E; + -- expansion: + -- accept_trivial (1); + + -- The compiler is also able to recognize the following and + -- translate it the same way. + + -- accept E do null; end E; + + procedure Accept_Trivial (E : Task_Entry_Index) is + Self_Id : constant Task_ID := STPO.Self; + Caller : Task_ID := null; + Open_Accepts : aliased Accept_List (1 .. 1); + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + -- If someone completed this task, this task should not try to + -- access its pending entry calls or queues in this case, as they + -- are being emptied. Wait for abortion to kill us. + -- ????? + -- Recheck the correctness of the above, now that we have made + -- changes. + + Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); + + if Entry_Call = null then + + -- Need to wait for entry call + + Open_Accepts (1).Null_Body := True; + Open_Accepts (1).S := E; + Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; + + pragma Debug + (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); + + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- No need to do anything special here for pending abort. + -- Abort_Signal will be raised by Undefer on exit. + + STPO.Unlock (Self_Id); + + else -- found caller already waiting + + pragma Assert (Entry_Call.State < Done); + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + end if; + + Initialization.Undefer_Abort_Nestable (Self_Id); + end Accept_Trivial; + + -------------------- + -- Boost_Priority -- + -------------------- + + -- Call this only with abort deferred and holding lock of Acceptor. + + procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is + Caller : Task_ID := Call.Self; + Caller_Prio : System.Any_Priority := Get_Priority (Caller); + Acceptor_Prio : System.Any_Priority := Get_Priority (Acceptor); + + begin + if Caller_Prio > Acceptor_Prio then + Call.Acceptor_Prev_Priority := Acceptor_Prio; + Set_Priority (Acceptor, Caller_Prio); + + else + Call.Acceptor_Prev_Priority := Priority_Not_Boosted; + end if; + end Boost_Priority; + + ----------------- + -- Call_Simple -- + ----------------- + + -- Compiler interface only. Do not call from within the RTS. + + procedure Call_Simple + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address) + is + Rendezvous_Successful : Boolean; + begin + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); + end Call_Simple; + + ---------------------- + -- Call_Synchronous -- + ---------------------- + + -- Compiler interface. + -- Also called from inside Call_Simple and Task_Entry_Call. + + procedure Call_Synchronous + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_ID := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + begin + pragma Assert (Mode /= Asynchronous_Call); + + Local_Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "CS: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + if Self_Id.Deferral_Level > 1 then + Entry_Call.State := Never_Abortable; + else + Entry_Call.State := Now_Abortable; + end if; + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + -- Note: the caller will undefer abortion on return (see WARNING above) + + if not Task_Do_Or_Queue + (Self_Id, Entry_Call, With_Abort => True) + then + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1; + Initialization.Undefer_Abort (Self_Id); + pragma Debug + (Debug.Trace (Self_Id, "CS: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + raise Tasking_Error; + end if; + + STPO.Write_Lock (Self_Id); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); + Entry_Calls.Wait_For_Completion (Self_Id, Entry_Call); + pragma Debug + (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); + Rendezvous_Successful := Entry_Call.State = Done; + STPO.Unlock (Self_Id); + Local_Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Call_Synchronous; + + -------------- + -- Callable -- + -------------- + + -- Compiler interface. + -- Do not call from within the RTS, + -- except for body of Ada.Task_Identification. + + function Callable (T : Task_ID) return Boolean is + Result : Boolean; + Self_Id : constant Task_ID := STPO.Self; + + begin + Initialization.Defer_Abort (Self_Id); + STPO.Write_Lock (T); + Result := T.Callable; + STPO.Unlock (T); + Initialization.Undefer_Abort (Self_Id); + return Result; + end Callable; + + ---------------------------- + -- Cancel_Task_Entry_Call -- + ---------------------------- + + -- Compiler interface only. Do not call from within the RTS. + -- Call only with abort deferred. + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); + end Cancel_Task_Entry_Call; + + ------------------------- + -- Complete_Rendezvous -- + ------------------------- + + -- See comments for Exceptional_Complete_Rendezvous. + + procedure Complete_Rendezvous is + begin + Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id); + end Complete_Rendezvous; + + ------------------------------------- + -- Exceptional_Complete_Rendezvous -- + ------------------------------------- + + -- Compiler interface. + -- Also called from Complete_Rendezvous. + -- ????? + -- Consider phasing out Complete_Rendezvous in favor + -- of direct call to this with Ada.Exceptions.Null_ID. + -- See code expansion examples for Accept_Call and Selective_Wait. + -- ????? + -- If we don't change the interface, consider instead + -- putting an explicit re-raise after this call, in + -- the generated code. That way we could eliminate the + -- code here that reraises the exception. + + -- The deferral level is critical here, + -- since we want to raise an exception or allow abort to take + -- place, if there is an exception or abort pending. + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id) + is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link := Self_Id.Common.Call; + Caller : Task_ID; + Called_PO : STPE.Protection_Entries_Access; + + Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex; + Ceiling_Violation : Boolean; + + use type Ada.Exceptions.Exception_Id; + procedure Internal_Reraise; + pragma Import (C, Internal_Reraise, "__gnat_reraise"); + + use type STPE.Protection_Entries_Access; + + begin + pragma Debug + (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R')); + + if Ex = Ada.Exceptions.Null_Id then + -- The call came from normal end-of-rendezvous, + -- so abort is not yet deferred. + Initialization.Defer_Abort_Nestable (Self_Id); + end if; + + -- We need to clean up any accepts which Self may have + -- been serving when it was aborted. + + if Ex = Standard'Abort_Signal'Identity then + while Entry_Call /= null loop + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + + -- All forms of accept make sure that the acceptor is not + -- completed, before accepting further calls, so that we + -- can be sure that no further calls are made after the + -- current calls are purged. + + Caller := Entry_Call.Self; + + -- Take write lock. This follows the lock precedence rule that + -- Caller may be locked while holding lock of Acceptor. + -- Complete the call abnormally, with exception. + + STPO.Write_Lock (Caller); + + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + Entry_Call := Entry_Call.Acceptor_Prev_Call; + end loop; + + else + Caller := Entry_Call.Self; + + if Entry_Call.Needs_Requeue then + -- We dare not lock Self_Id at the same time as Caller, + -- for fear of deadlock. + + Entry_Call.Needs_Requeue := False; + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + + if Entry_Call.Called_Task /= null then + -- Requeue to another task entry + + if not Task_Do_Or_Queue + (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort) + then + Initialization.Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + else + -- Requeue to a protected entry + + Called_PO := POE.To_Protection (Entry_Call.Called_PO); + STPE.Lock_Entries (Called_PO, Ceiling_Violation); + + if Ceiling_Violation then + pragma Assert (Ex = Ada.Exceptions.Null_Id); + + Exception_To_Raise := Program_Error'Identity; + Entry_Call.Exception_To_Raise := Exception_To_Raise; + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller + (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + else + POO.PO_Do_Or_Queue + (Self_Id, Called_PO, Entry_Call, + Entry_Call.Requeue_With_Abort); + POO.PO_Service_Entries (Self_Id, Called_PO); + STPE.Unlock_Entries (Called_PO); + end if; + end if; + + Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority, + Self_Id); + + else + -- The call does not need to be requeued. + + Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; + Entry_Call.Exception_To_Raise := Ex; + STPO.Write_Lock (Caller); + + -- Done with Caller locked to make sure that Wakeup is not lost. + + if Ex /= Ada.Exceptions.Null_Id then + Ada.Exceptions.Save_Occurrence + (Caller.Common.Compiler_Data.Current_Excep, + Self_Id.Common.Compiler_Data.Current_Excep); + end if; + + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + Entry_Calls.Reset_Priority (Entry_Call.Acceptor_Prev_Priority, + Self_Id); + end if; + end if; + + Initialization.Undefer_Abort (Self_Id); + + if Exception_To_Raise /= Ada.Exceptions.Null_Id then + Internal_Reraise; + end if; + + -- ????? + -- Do we need to + -- give precedence to Program_Error that might be raised + -- due to failure of finalization, over Tasking_Error from + -- failure of requeue? + end Exceptional_Complete_Rendezvous; + + ------------------- + -- Is_Entry_Open -- + ------------------- + + -- Call this only with abort deferred and holding lock of T. + + function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean is + begin + pragma Assert (T.Open_Accepts /= null); + + if T.Open_Accepts /= null then + for J in T.Open_Accepts'Range loop + + pragma Assert (J > 0); + + if E = T.Open_Accepts (J).S then + return True; + end if; + end loop; + end if; + + return False; + end Is_Entry_Open; + + ------------------------------------- + -- Requeue_Protected_To_Task_Entry -- + ------------------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + -- entry e2 when b is + -- begin + -- b := false; + -- ...A... + -- requeue t.e2; + -- end e2; + + -- procedure rPT__E14b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_to_task_entry (rR'unchecked_access, tTV!(t). + -- _task_id, 2, false); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E14b; + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_ID; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + begin + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Requeue_With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_To_Task_Entry; + + ------------------------ + -- Requeue_Task_Entry -- + ------------------------ + + -- Compiler interface only. Do not call from within the RTS. + -- The code generation for task entry requeues is different from that + -- for protected entry requeues. There is a "goto" that skips around + -- the call to Complete_Rendezous, so that Requeue_Task_Entry must also + -- do the work of Complete_Rendezvous. The difference is that it does + -- not report that the call's State = Done. + + -- accept e1 do + -- ...A... + -- requeue e2; + -- ...B... + -- end e1; + + -- A62b : address; + -- L61b : label + -- begin + -- accept_call (1, A62b); + -- ...A... + -- requeue_task_entry (tTV!(t)._task_id, 2, false); + -- goto L61b; + -- ...B... + -- complete_rendezvous; + -- <<L61b>> + -- exception + -- when others => + -- exceptional_complete_rendezvous (current_exception); + -- end; + + procedure Requeue_Task_Entry + (Acceptor : Task_ID; + E : Task_Entry_Index; + With_Abort : Boolean) + is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; + + begin + Initialization.Defer_Abort (Self_Id); + Entry_Call.Needs_Requeue := True; + Entry_Call.Requeue_With_Abort := With_Abort; + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_Task := Acceptor; + Initialization.Undefer_Abort (Self_Id); + end Requeue_Task_Entry; + + -------------------- + -- Selective_Wait -- + -------------------- + + -- Compiler interface only. Do not call from within the RTS. + -- See comments on Accept_Call. + + -- source code: + + -- select accept e1 do + -- ...A... + -- end e1; + -- ...B... + -- or accept e2; + -- ...C... + -- end select; + + -- expansion: + + -- A32b : address; + -- declare + -- null; + -- if accept_alternative'size * 2 >= 16#8000_0000# then + -- raise storage_error; + -- end if; + -- A37b : T36b; + -- A37b (1) := (null_body => false, s => 1); + -- A37b (2) := (null_body => true, s => 2); + -- if accept_alternative'size * 2 >= 16#8000_0000# then + -- raise storage_error; + -- end if; + -- S0 : aliased T36b := accept_list'A37b; + -- J1 : select_index := 0; + -- L3 : label + -- L1 : label + -- L2 : label + -- procedure e1A is + -- begin + -- abort_undefer.all; + -- L31b : label + -- ...A... + -- <<L31b>> + -- complete_rendezvous; + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end e1A; + -- begin + -- selective_wait (S0'unchecked_access, simple_mode, A32b, J1); + -- case J1 is + -- when 0 => + -- goto L3; + -- when 1 => + -- e1A; + -- goto L1; + -- when 2 => + -- goto L2; + -- when others => + -- goto L3; + -- end case; + -- <<L1>> + -- ...B... + -- goto L3; + -- <<L2>> + -- ...C... + -- goto L3; + -- <<L3>> + -- end; + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index) + is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + Treatment : Select_Treatment; + Caller : Task_ID; + Selection : Select_Index; + Open_Alternative : Boolean; + + begin + Initialization.Defer_Abort (Self_Id); + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + + -- ??? In some cases abort is deferred more than once. Need to figure + -- out why. + + Self_Id.Deferral_Level := 1; + + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + -- If someone completed this task, this task should not try to + -- access its pending entry calls or queues in this case, as they + -- are being emptied. Wait for abortion to kill us. + -- ????? + -- Recheck the correctness of the above, now that we have made + -- changes. + + pragma Assert (Open_Accepts /= null); + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select. + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- ?????? + -- Recheck the logic above against the ARM. + + -- Handle the select according to the disposition selected above. + + case Treatment is + + when Accept_Alternative_Selected => + + -- Ready to rendezvous + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + -- In this case the accept body is not Null_Body. Defer abortion + -- until it gets into the accept body. + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Accept body is null, so rendezvous is over immediately. + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller. + + Self_Id.Open_Accepts := Open_Accepts; + pragma Debug + (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); + Wait_For_Call (Self_Id); + + pragma Assert (Self_Id.Open_Accepts = null); + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abortion. + -- Therefore, if the call is not empty we need to do the rendezvous + -- if the accept body is not Null_Body. + + -- ????? + -- aren't the first two conditions below redundant? + + if Self_Id.Chosen_Index /= No_Rendezvous and then + Self_Id.Common.Call /= null and then + not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + end if; + + STPO.Unlock (Self_Id); + + when Else_Selected => + pragma Assert (Self_Id.Open_Accepts = null); + + STPO.Unlock (Self_Id); + + when Terminate_Selected => + + -- Terminate alternative is open + + Self_Id.Open_Accepts := Open_Accepts; + Self_Id.Common.State := Acceptor_Sleep; + STPO.Unlock (Self_Id); + + -- ????? + -- We need to check if a signal is pending on an open interrupt + -- entry. Otherwise this task would become potentially terminatable + -- and, if none of the siblings are active + -- any more, the task could not wake up any more, even though a + -- signal might be pending on an open interrupt entry. + -- ------------- + -- This comment paragraph does not make sense. Is it obsolete? + -- There was no code here to check for pending signals. + + -- Notify ancestors that this task is on a terminate alternative. + + Utilities.Make_Passive (Self_Id, Task_Completed => False); + + -- Wait for normal entry call or termination + + pragma Assert (Self_Id.ATC_Nesting_Level = 1); + + STPO.Write_Lock (Self_Id); + + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Open_Accepts = null; + Sleep (Self_Id, Acceptor_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + + pragma Assert (Self_Id.Open_Accepts = null); + + if Self_Id.Terminate_Alternative then + + -- An entry call should have reset this to False, + -- so we must be aborted. + -- We cannot be in an async. select, since that + -- is not legal, so the abort must be of the entire + -- task. Therefore, we do not need to cancel the + -- terminate alternative. The cleanup will be done + -- in Complete_Master. + + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Awake_Count = 0); + + -- Trust that it is OK to fall through. + + null; + + else + -- Self_Id.Common.Call and Self_Id.Chosen_Index + -- should already be updated by the Caller. + + if Self_Id.Chosen_Index /= No_Rendezvous + and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + -- We need an extra defer here, to keep abort + -- deferred until we get into the accept body + + Initialization.Defer_Abort_Nestable (Self_Id); + end if; + end if; + + STPO.Unlock (Self_Id); + + when No_Alternative_Open => + + -- In this case, Index will be No_Rendezvous on return, which + -- should cause a Program_Error if it is not a Delay_Mode. + + -- If delay alternative exists (Delay_Mode) we should suspend + -- until the delay expires. + + Self_Id.Open_Accepts := null; + + if Select_Mode = Delay_Mode then + Self_Id.Common.State := Delay_Sleep; + + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; + Sleep (Self_Id, Delay_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); + + else + STPO.Unlock (Self_Id); + Initialization.Undefer_Abort (Self_Id); + Ada.Exceptions.Raise_Exception (Program_Error'Identity, + "Entry call not a delay mode"); + end if; + + end case; + + -- Caller has been chosen. + -- Self_Id.Common.Call should already be updated by the Caller. + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait. + -- On return, we sill start rendezvous unless the accept body is + -- null. In the latter case, we will have already completed the RV. + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + end Selective_Wait; + + ------------------------------------ + -- Setup_For_Rendezvous_With_Body -- + ------------------------------------ + + -- Call this only with abort deferred and holding lock of Acceptor. + + procedure Setup_For_Rendezvous_With_Body + (Entry_Call : Entry_Call_Link; + Acceptor : Task_ID) + is + begin + Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; + Acceptor.Common.Call := Entry_Call; + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Boost_Priority (Entry_Call, Acceptor); + end Setup_For_Rendezvous_With_Body; + + ---------------- + -- Task_Count -- + ---------------- + + -- Compiler interface only. Do not call from within the RTS. + + function Task_Count (E : Task_Entry_Index) return Natural is + Self_Id : constant Task_ID := STPO.Self; + Return_Count : Natural; + + begin + Initialization.Defer_Abort (Self_Id); + STPO.Write_Lock (Self_Id); + Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); + STPO.Unlock (Self_Id); + Initialization.Undefer_Abort (Self_Id); + return Return_Count; + end Task_Count; + + ---------------------- + -- Task_Do_Or_Queue -- + ---------------------- + + -- Call this only with abort deferred and holding no locks. + -- May propagate an exception, including Abort_Signal & Tasking_Error. + -- ????? + -- See Check_Callable. Check all call contexts to verify + -- it is OK to raise an exception. + + -- Find out whether Entry_Call can be accepted immediately. + -- If the Acceptor is not callable, raise Tasking_Error. + -- If the rendezvous can start, initiate it. + -- If the accept-body is trivial, also complete the rendezvous. + -- If the acceptor is not ready, enqueue the call. + + -- ????? + -- This should have a special case for Accept_Call and + -- Accept_Trivial, so that + -- we don't have the loop setup overhead, below. + + -- ????? + -- The call state Done is used here and elsewhere to include + -- both the case of normal successful completion, and the case + -- of an exception being raised. The difference is that if an + -- exception is raised no one will pay attention to the fact + -- that State = Done. Instead the exception will be raised in + -- Undefer_Abort, and control will skip past the place where + -- we normally would resume from an entry call. + + function Task_Do_Or_Queue + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + With_Abort : Boolean) return Boolean + is + E : constant Task_Entry_Index := Task_Entry_Index (Entry_Call.E); + Old_State : constant Entry_Call_State := Entry_Call.State; + Acceptor : constant Task_ID := Entry_Call.Called_Task; + Parent : constant Task_ID := Acceptor.Common.Parent; + Parent_Locked : Boolean := False; + Null_Body : Boolean; + + begin + pragma Assert (not Queuing.Onqueue (Entry_Call)); + + -- We rely that the call is off-queue for protection, + -- that the caller will not exit the Entry_Caller_Sleep, + -- and so will not reuse the call record for another call. + -- We rely on the Caller's lock for call State mod's. + + -- We can't lock Acceptor.Parent while holding Acceptor, + -- so lock it in advance if we expect to need to lock it. + -- ????? + -- Is there some better solution? + + if Acceptor.Terminate_Alternative then + STPO.Write_Lock (Parent); + Parent_Locked := True; + end if; + + STPO.Write_Lock (Acceptor); + + -- If the acceptor is not callable, abort the call + -- and raise Tasking_Error. The call is not aborted + -- for an asynchronous call, since Cancel_Task_Entry_Call + -- will do the cancelation in that case. + -- ????? ..... + -- Does the above still make sense? + + if not Acceptor.Callable then + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Acceptor.Common.Parent); + end if; + + pragma Assert (Entry_Call.State < Done); + + -- In case we are not the caller, set up the caller + -- to raise Tasking_Error when it wakes up. + + STPO.Write_Lock (Entry_Call.Self); + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + return False; + end if; + + -- Try to serve the call immediately. + + if Acceptor.Open_Accepts /= null then + for J in Acceptor.Open_Accepts'Range loop + if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then + + -- Commit acceptor to rendezvous with us. + + Acceptor.Chosen_Index := J; + Null_Body := Acceptor.Open_Accepts (J).Null_Body; + Acceptor.Open_Accepts := null; + + -- Prevent abort while call is being served. + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + if Acceptor.Terminate_Alternative then + + -- Cancel terminate alternative. + -- See matching code in Selective_Wait and + -- Vulnerable_Complete_Master. + + Acceptor.Terminate_Alternative := False; + Acceptor.Awake_Count := Acceptor.Awake_Count + 1; + + if Acceptor.Awake_Count = 1 then + + -- Notify parent that acceptor is awake. + + pragma Assert (Parent.Awake_Count > 0); + + Parent.Awake_Count := Parent.Awake_Count + 1; + + if Parent.Common.State = Master_Completion_Sleep and then + Acceptor.Master_of_Task = Parent.Master_Within + then + Parent.Common.Wait_Count := + Parent.Common.Wait_Count + 1; + end if; + end if; + end if; + + if Null_Body then + + -- Rendezvous is over immediately. + + STPO.Wakeup (Acceptor, Acceptor_Sleep); + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + STPO.Write_Lock (Entry_Call.Self); + Initialization.Wakeup_Entry_Caller + (Self_ID, Entry_Call, Done); + STPO.Unlock (Entry_Call.Self); + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); + + -- For terminate_alternative, acceptor may not be + -- asleep yet, so we skip the wakeup + + if Acceptor.Common.State /= Runnable then + STPO.Wakeup (Acceptor, Acceptor_Sleep); + end if; + + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + end if; + + return True; + end if; + end loop; + + -- The acceptor is accepting, but not this entry. + end if; + + -- If the acceptor was ready to accept this call, + -- we would not have gotten this far, so now we should + -- (re)enqueue the call, if the mode permits that. + + if Entry_Call.Mode /= Conditional_Call + or else not With_Abort + then + -- Timed_Call, Simple_Call, or Asynchronous_Call + + Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); + + -- Update abortability of call + + pragma Assert (Old_State < Done); + + Entry_Call.State := New_State (With_Abort, Entry_Call.State); + + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + if Old_State /= Entry_Call.State and then + Entry_Call.State = Now_Abortable and then + Entry_Call.Mode > Simple_Call and then + + -- Asynchronous_Call or Conditional_Call + + Entry_Call.Self /= Self_ID + + then + -- Because of ATCB lock ordering rule + + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + + -- Caller may not yet have reached wait-point + + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + end if; + + else + -- Conditional_Call and With_Abort + + STPO.Unlock (Acceptor); + + if Parent_Locked then + STPO.Unlock (Parent); + end if; + + STPO.Write_Lock (Entry_Call.Self); + + pragma Assert (Entry_Call.State >= Was_Abortable); + + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + end if; + + return True; + end Task_Do_Or_Queue; + + --------------------- + -- Task_Entry_Call -- + --------------------- + + procedure Task_Entry_Call + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + if Mode = Simple_Call or else Mode = Conditional_Call then + Call_Synchronous + (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); + + else + -- This is an asynchronous call + + -- Abortion must already be deferred by the compiler-generated + -- code. Without this, an abortion that occurs between the time + -- that this call is made and the time that the abortable part's + -- cleanup handler is set up might miss the cleanup handler and + -- leave the call pending. + + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_Id, "TEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + Entry_Call.State := Not_Yet_Abortable; + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + if not Task_Do_Or_Queue + (Self_Id, Entry_Call, With_Abort => True) + then + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1; + pragma Debug + (Debug.Trace (Self_Id, "TEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + Initialization.Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + -- The following is special for async. entry calls. + -- If the call was not queued abortably, we need to wait until + -- it is before proceeding with the abortable part. + + -- Wait_Until_Abortable can be called unconditionally here, + -- but it is expensive. + + if Entry_Call.State < Was_Abortable then + Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); + end if; + + -- Note: following assignment needs to be atomic. + + Rendezvous_Successful := Entry_Call.State = Done; + end if; + end Task_Entry_Call; + + ----------------------- + -- Task_Entry_Caller -- + ----------------------- + + -- Compiler interface only. + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + + begin + Entry_Call := Self_Id.Common.Call; + for Depth in 1 .. D loop + Entry_Call := Entry_Call.Acceptor_Prev_Call; + pragma Assert (Entry_Call /= null); + end loop; + + return Entry_Call.Self; + end Task_Entry_Caller; + + -------------------------- + -- Timed_Selective_Wait -- + -------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index) + is + Self_Id : constant Task_ID := STPO.Self; + Treatment : Select_Treatment; + Entry_Call : Entry_Call_Link; + Caller : Task_ID; + Selection : Select_Index; + Open_Alternative : Boolean; + Timedout : Boolean := False; + Yielded : Boolean := False; + begin + pragma Assert (Select_Mode = Delay_Mode); + + Initialization.Defer_Abort (Self_Id); + + -- If we are aborted here, the effect will be pending + + STPO.Write_Lock (Self_Id); + + if not Self_Id.Callable then + pragma Assert (Self_Id.Pending_ATC_Level = 0); + + pragma Assert (Self_Id.Pending_Action); + + STPO.Unlock (Self_Id); + Initialization.Undefer_Abort (Self_Id); + + -- Should never get here ??? + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + -- If someone completed this task, this task should not try to + -- access its pending entry calls or queues in this case, as they + -- are being emptied. Wait for abortion to kill us. + -- ????? + -- Recheck the correctness of the above, now that we have made + -- changes. + + pragma Assert (Open_Accepts /= null); + + Queuing.Select_Task_Entry_Call + (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); + + -- Determine the kind and disposition of the select. + + Treatment := Default_Treatment (Select_Mode); + Self_Id.Chosen_Index := No_Rendezvous; + + if Open_Alternative then + if Entry_Call /= null then + if Open_Accepts (Selection).Null_Body then + Treatment := Accept_Alternative_Completed; + + else + Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); + Treatment := Accept_Alternative_Selected; + end if; + + Self_Id.Chosen_Index := Selection; + + elsif Treatment = No_Alternative_Open then + Treatment := Accept_Alternative_Open; + end if; + end if; + + -- Handle the select according to the disposition selected above. + + case Treatment is + + when Accept_Alternative_Selected => + + -- Ready to rendezvous + -- In this case the accept body is not Null_Body. Defer abortion + -- until it gets into the accept body. + + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + Initialization.Defer_Abort (Self_Id); + STPO.Unlock (Self_Id); + + when Accept_Alternative_Completed => + + -- Rendezvous is over + + STPO.Unlock (Self_Id); + Caller := Entry_Call.Self; + + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + + when Accept_Alternative_Open => + + -- Wait for caller. + + Self_Id.Open_Accepts := Open_Accepts; + + -- Wait for a normal call and a pending action until the + -- Wakeup_Time is reached. + + Self_Id.Common.State := Acceptor_Sleep; + + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + exit when Self_Id.Open_Accepts = null; + + if Timedout then + Sleep (Self_Id, Acceptor_Sleep); + else + STPO.Timed_Sleep (Self_Id, Timeout, Mode, + Acceptor_Sleep, Timedout, Yielded); + end if; + + if Timedout then + Self_Id.Open_Accepts := null; + end if; + end loop; + + Self_Id.Common.State := Runnable; + + -- Self_Id.Common.Call should already be updated by the Caller if + -- not aborted. It might also be ready to do rendezvous even if + -- this wakes up due to an abortion. + -- Therefore, if the call is not empty we need to do the rendezvous + -- if the accept body is not Null_Body. + + if Self_Id.Chosen_Index /= No_Rendezvous and then + Self_Id.Common.Call /= null and then + not Open_Accepts (Self_Id.Chosen_Index).Null_Body + then + Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; + + pragma Assert (Self_Id.Deferral_Level = 1); + + Initialization.Defer_Abort_Nestable (Self_Id); + + -- Leave abort deferred until the accept body + + end if; + + STPO.Unlock (Self_Id); + if not Yielded then + Yield; + end if; + + when No_Alternative_Open => + + -- In this case, Index will be No_Rendezvous on return. We sleep + -- for the time we need to. + -- Wait for a signal or timeout. A wakeup can be made + -- for several reasons: + -- 1) Delay is expired + -- 2) Pending_Action needs to be checked + -- (Abortion, Priority change) + -- 3) Spurious wakeup + + Self_Id.Open_Accepts := null; + Self_Id.Common.State := Acceptor_Sleep; + + Initialization.Poll_Base_Priority_Change (Self_Id); + + STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep, + Timedout, Yielded); + + Self_Id.Common.State := Runnable; + + STPO.Unlock (Self_Id); + + if not Yielded then + Yield; + end if; + + when others => + -- Should never get here ??? + + pragma Assert (False); + null; + end case; + + -- Caller has been chosen + + -- Self_Id.Common.Call should already be updated by the Caller + + -- Self_Id.Chosen_Index should either be updated by the Caller + -- or by Test_Selective_Wait + + Index := Self_Id.Chosen_Index; + Initialization.Undefer_Abort_Nestable (Self_Id); + + -- Start rendezvous, if not already completed + + end Timed_Selective_Wait; + + --------------------------- + -- Timed_Task_Entry_Call -- + --------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + procedure Timed_Task_Entry_Call + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean) + is + Self_Id : constant Task_ID := STPO.Self; + Level : ATC_Level; + Entry_Call : Entry_Call_Link; + + begin + Initialization.Defer_Abort (Self_Id); + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; + + pragma Debug + (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + Level := Self_Id.ATC_Nesting_Level; + Entry_Call := Self_Id.Entry_Calls (Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + if Self_Id.Deferral_Level > 1 then + Entry_Call.State := Never_Abortable; + else + Entry_Call.State := Now_Abortable; + end if; + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := Get_Priority (Self_Id); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_Task := Acceptor; + Entry_Call.Called_PO := Null_Address; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + -- Note: the caller will undefer abortion on return (see WARNING above) + + if not Task_Do_Or_Queue + (Self_Id, Entry_Call, With_Abort => True) + then + Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level - 1; + + pragma Debug + (Debug.Trace (Self_Id, "TTEC: exited to ATC level: " & + ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); + + Initialization.Undefer_Abort (Self_Id); + raise Tasking_Error; + end if; + + Entry_Calls.Wait_For_Completion_With_Timeout + (Self_Id, Entry_Call, Timeout, Mode); + Rendezvous_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort (Self_Id); + Entry_Calls.Check_Exception (Self_Id, Entry_Call); + end Timed_Task_Entry_Call; + + ------------------- + -- Wait_For_Call -- + ------------------- + + -- Call this only with abort deferred and holding lock of Self_Id. + -- Wait for normal call and a pending action. + + procedure Wait_For_Call (Self_Id : Task_ID) is + begin + Self_Id.Common.State := Acceptor_Sleep; + + loop + Initialization.Poll_Base_Priority_Change (Self_Id); + + exit when Self_Id.Open_Accepts = null; + + Sleep (Self_Id, Acceptor_Sleep); + end loop; + + Self_Id.Common.State := Runnable; + end Wait_For_Call; + +end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tasren.ads b/gcc/ada/s-tasren.ads new file mode 100644 index 00000000000..97c21428b58 --- /dev/null +++ b/gcc/ada/s-tasren.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.26 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; +-- Used for, Exception_Id + +with System.Tasking.Protected_Objects.Entries; +-- used for Protection_Entries + +package System.Tasking.Rendezvous is + -- This interface is described in the document + -- Gnu Ada Runtime Library Interface (GNARLI). + + package STPE renames System.Tasking.Protected_Objects.Entries; + + procedure Task_Entry_Call + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Rendezvous_Successful : out Boolean); + -- General entry call + + procedure Timed_Task_Entry_Call + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Rendezvous_Successful : out Boolean); + -- Timed entry call without using ATC. + + procedure Call_Simple + (Acceptor : Task_ID; + E : Task_Entry_Index; + Uninterpreted_Data : System.Address); + -- Simple entry call + + procedure Cancel_Task_Entry_Call (Cancelled : out Boolean); + -- Cancel pending task entry call + + procedure Requeue_Task_Entry + (Acceptor : Task_ID; + E : Task_Entry_Index; + With_Abort : Boolean); + + procedure Requeue_Protected_To_Task_Entry + (Object : STPE.Protection_Entries_Access; + Acceptor : Task_ID; + E : Task_Entry_Index; + With_Abort : Boolean); + + procedure Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Index : out Select_Index); + -- Selective wait + + procedure Timed_Selective_Wait + (Open_Accepts : Accept_List_Access; + Select_Mode : Select_Modes; + Uninterpreted_Data : out System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Index : out Select_Index); + -- Selective wait with timeout without using ATC. + + procedure Accept_Call + (E : Task_Entry_Index; + Uninterpreted_Data : out System.Address); + -- Accept an entry call + + procedure Accept_Trivial (E : Task_Entry_Index); + -- Accept an entry call that has no parameters and no body + + function Task_Count (E : Task_Entry_Index) return Natural; + -- Return number of tasks waiting on the entry E (of current task) + + function Callable (T : Task_ID) return Boolean; + -- Return T'CALLABLE + + type Task_Entry_Nesting_Depth is new Task_Entry_Index + range 0 .. Max_Task_Entry; + + function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_ID; + -- Return E'Caller. This will only work if called from within an + -- accept statement that is handling E, as required by the + -- LRM (C.7.1(14)). + + procedure Complete_Rendezvous; + -- Called by acceptor to wake up caller + + procedure Exceptional_Complete_Rendezvous + (Ex : Ada.Exceptions.Exception_Id); + -- Called by acceptor to mark the end of the current rendezvous and + -- propagate an exception to the caller. + + -- For internal use only: + + function Task_Do_Or_Queue + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + With_Abort : Boolean) return Boolean; + -- Call this only with abort deferred and holding lock of Acceptor. + -- Returns False iff the call cannot be served or queued, as is the + -- case if the caller is not callable; i.e., a False return value + -- indicates that Tasking_Error should be raised. + -- Either initiate the entry call, such that the accepting task is + -- free to execute the rendezvous, queue the call on the acceptor's + -- queue, or cancel the call. Conditional calls that cannot be + -- accepted immediately are cancelled. + +end System.Tasking.Rendezvous; diff --git a/gcc/ada/s-tasres.ads b/gcc/ada/s-tasres.ads new file mode 100644 index 00000000000..52af39eeed1 --- /dev/null +++ b/gcc/ada/s-tasres.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . R E S T R I C T E D -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.1 $ +-- -- +-- Copyright (C) 1998-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). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the parent package of the GNAT restricted tasking run time + +package System.Tasking.Restricted is +end System.Tasking.Restricted; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb new file mode 100644 index 00000000000..3c265f2f1d2 --- /dev/null +++ b/gcc/ada/s-tassta.adb @@ -0,0 +1,1549 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . S T A G E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.138 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Ada.Exceptions; +-- used for Raise_Exception + +with System.Tasking.Debug; +pragma Warnings (Off, System.Tasking.Debug); +-- used for enabling tasking facilities with gdb + +with System.Address_Image; +-- used for the function itself. + +with System.Parameters; +-- used for Size_Type + +with System.Task_Info; +-- used for Task_Info_Type +-- Task_Image_Type + +with System.Task_Primitives.Operations; +-- used for Finalize_Lock +-- Enter_Task +-- Write_Lock +-- Unlock +-- Sleep +-- Wakeup +-- Get_Priority +-- Lock/Unlock_All_Tasks_List +-- New_ATCB + +with System.Soft_Links; +-- These are procedure pointers to non-tasking routines that use +-- task specific data. In the absence of tasking, these routines +-- refer to global data. In the presense of tasking, they must be +-- replaced with pointers to task-specific versions. +-- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep + +with System.Tasking.Initialization; +-- Used for Remove_From_All_Tasks_List +-- Defer_Abort +-- Undefer_Abort +-- Initialization.Poll_Base_Priority_Change +-- Finalize_Attributes_Link +-- Initialize_Attributes_Link + +pragma Elaborate_All (System.Tasking.Initialization); +-- This insures that tasking is initialized if any tasks are created. + +with System.Tasking.Utilities; +-- Used for Make_Passive +-- Abort_One_Task + +with System.Tasking.Queuing; +-- Used for Dequeue_Head + +with System.Tasking.Rendezvous; +-- Used for Call_Simple + +with System.OS_Primitives; +-- Used for Delay_Modes + +with System.Finalization_Implementation; +-- Used for System.Finalization_Implementation.Finalize_Global_List + +with Interfaces.C; +-- Used for type Unsigned. + +with System.Secondary_Stack; +-- used for SS_Init; + +with System.Storage_Elements; +-- used for Storage_Array; + +with System.Standard_Library; +-- used for Exception_Trace + +package body System.Tasking.Stages is + + package STPO renames System.Task_Primitives.Operations; + package SSL renames System.Soft_Links; + package SSE renames System.Storage_Elements; + package SST renames System.Secondary_Stack; + + use Ada.Exceptions; + + use System.Task_Primitives; + use System.Task_Primitives.Operations; + use System.Task_Info; + + procedure Wakeup_Entry_Caller + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + renames Initialization.Wakeup_Entry_Caller; + + procedure Cancel_Queued_Entry_Calls (T : Task_ID) + renames Utilities.Cancel_Queued_Entry_Calls; + + procedure Abort_One_Task + (Self_ID : Task_ID; + T : Task_ID) + renames Utilities.Abort_One_Task; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Notify_Exception + (Self_Id : Task_ID; + Excep : Exception_Occurrence); + -- This procedure will output the task ID and the exception information, + -- including traceback if available. + + procedure Task_Wrapper (Self_ID : Task_ID); + -- This is the procedure that is called by the GNULL from the + -- new context when a task is created. It waits for activation + -- and then calls the task body procedure. When the task body + -- procedure completes, it terminates the task. + + procedure Vulnerable_Complete_Task (Self_ID : Task_ID); + -- Complete the calling task. + -- This procedure must be called with abort deferred. + -- It should only be called by Complete_Task and + -- Finalizate_Global_Tasks (for the environment task). + + procedure Vulnerable_Complete_Master (Self_ID : Task_ID); + -- Complete the current master of the calling task. + -- This procedure must be called with abort deferred. + -- It should only be called by Vulnerable_Complete_Task and + -- Complete_Master. + + procedure Vulnerable_Complete_Activation (Self_ID : Task_ID); + -- Signal to Self_ID's activator that Self_ID has + -- completed activation. + -- + -- Does not defer abortion (unlike Complete_Activation). + + procedure Abort_Dependents (Self_ID : Task_ID); + -- Abort all the dependents of Self at our current master + -- nesting level. + + procedure Vulnerable_Free_Task (T : Task_ID); + -- Recover all runtime system storage associated with the task T. + -- This should only be called after T has terminated and will no + -- longer be referenced. + -- + -- For tasks created by an allocator that fails, due to an exception, + -- it is called from Expunge_Unactivated_Tasks. + -- + -- It is also called from Unchecked_Deallocation, for objects that + -- are or contain tasks. + -- + -- Different code is used at master completion, in Terminate_Dependents, + -- due to a need for tighter synchronization with the master. + + procedure Terminate_Task (Self_ID : Task_ID); + -- Terminate the calling task. + -- This should only be called by the Task_Wrapper procedure. + + ---------------------- + -- Abort_Dependents -- + ---------------------- + + -- Abort all the direct dependents of Self at its current master + -- nesting level, plus all of their dependents, transitively. + -- No locks should be held when this routine is called. + + procedure Abort_Dependents (Self_ID : Task_ID) is + C : Task_ID; + P : Task_ID; + + begin + Lock_All_Tasks_List; + + C := All_Tasks_List; + while C /= null loop + P := C.Common.Parent; + while P /= null loop + if P = Self_ID then + + -- ??? C is supposed to take care of its own dependents, so + -- there should be no need to take worry about them. Need to + -- double check this. + + if C.Master_of_Task = Self_ID.Master_Within then + Abort_One_Task (Self_ID, C); + C.Dependents_Aborted := True; + end if; + + exit; + end if; + + P := P.Common.Parent; + end loop; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Dependents_Aborted := True; + Unlock_All_Tasks_List; + end Abort_Dependents; + + ----------------- + -- Abort_Tasks -- + ----------------- + + procedure Abort_Tasks (Tasks : Task_List) is + begin + Utilities.Abort_Tasks (Tasks); + end Abort_Tasks; + + -------------------- + -- Activate_Tasks -- + -------------------- + + -- Note that locks of activator and activated task are both locked + -- here. This is necessary because C.Common.State and + -- Self.Common.Wait_Count have to be synchronized. This is safe from + -- deadlock because the activator is always created before the activated + -- task. That satisfies our in-order-of-creation ATCB locking policy. + + -- At one point, we may also lock the parent, if the parent is + -- different from the activator. That is also consistent with the + -- lock ordering policy, since the activator cannot be created + -- before the parent. + + -- Since we are holding both the activator's lock, and Task_Wrapper + -- locks that before it does anything more than initialize the + -- low-level ATCB components, it should be safe to wait to update + -- the counts until we see that the thread creation is successful. + + -- If the thread creation fails, we do need to close the entries + -- of the task. The first phase, of dequeuing calls, only requires + -- locking the acceptor's ATCB, but the waking up of the callers + -- requires locking the caller's ATCB. We cannot safely do this + -- while we are holding other locks. Therefore, the queue-clearing + -- operation is done in a separate pass over the activation chain. + + procedure Activate_Tasks + (Chain_Access : Activation_Chain_Access) + is + Self_ID : constant Task_ID := STPO.Self; + P : Task_ID; + C : Task_ID; + Next_C, Last_C : Task_ID; + Activate_Prio : System.Any_Priority; + Success : Boolean; + All_Elaborated : Boolean := True; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); + + Initialization.Defer_Abort_Nestable (Self_ID); + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Lock All_Tasks_L, to prevent activated tasks + -- from racing ahead before we finish activating the chain. + + -- ????? + -- Is there some less heavy-handed way? + -- In an earlier version, we used the activator's lock here, + -- but that violated the locking order rule when we had + -- to lock the parent later. + + Lock_All_Tasks_List; + + -- Check that all task bodies have been elaborated. + + C := Chain_Access.T_ID; + Last_C := null; + while C /= null loop + if C.Common.Elaborated /= null + and then not C.Common.Elaborated.all + then + All_Elaborated := False; + end if; + + -- Reverse the activation chain so that tasks are + -- activated in the same order they're declared. + + Next_C := C.Common.Activation_Link; + C.Common.Activation_Link := Last_C; + Last_C := C; + C := Next_C; + end loop; + + Chain_Access.T_ID := Last_C; + + if not All_Elaborated then + Unlock_All_Tasks_List; + Initialization.Undefer_Abort_Nestable (Self_ID); + Raise_Exception + (Program_Error'Identity, "Some tasks have not been elaborated"); + end if; + + -- Activate all the tasks in the chain. + -- Creation of the thread of control was deferred until + -- activation. So create it now. + + C := Chain_Access.T_ID; + while C /= null loop + if C.Common.State /= Terminated then + pragma Assert (C.Common.State = Unactivated); + + P := C.Common.Parent; + Write_Lock (P); + Write_Lock (C); + + if C.Common.Base_Priority < Get_Priority (Self_ID) then + Activate_Prio := Get_Priority (Self_ID); + else + Activate_Prio := C.Common.Base_Priority; + end if; + + System.Task_Primitives.Operations.Create_Task + (C, Task_Wrapper'Address, + Parameters.Size_Type + (C.Common.Compiler_Data.Pri_Stack_Info.Size), + Activate_Prio, Success); + + -- There would be a race between the created task and + -- the creator to do the following initialization, + -- if we did not have a Lock/Unlock_All_Tasks_List pair + -- in the task wrapper, to prevent it from racing ahead. + + if Success then + C.Common.State := Runnable; + C.Awake_Count := 1; + C.Alive_Count := 1; + P.Awake_Count := P.Awake_Count + 1; + P.Alive_Count := P.Alive_Count + 1; + + if P.Common.State = Master_Completion_Sleep and then + C.Master_of_Task = P.Master_Within + then + pragma Assert (Self_ID /= P); + P.Common.Wait_Count := P.Common.Wait_Count + 1; + end if; + + Unlock (C); + Unlock (P); + + else + -- No need to set Awake_Count, State, etc. here since the loop + -- below will do that for any Unactivated tasks. + + Unlock (C); + Unlock (P); + Self_ID.Common.Activation_Failed := True; + end if; + end if; + + C := C.Common.Activation_Link; + end loop; + + Unlock_All_Tasks_List; + + -- Close the entries of any tasks that failed thread creation, + -- and count those that have not finished activation. + + Write_Lock (Self_ID); + Self_ID.Common.State := Activator_Sleep; + + C := Chain_Access.T_ID; + while C /= null loop + Write_Lock (C); + + if C.Common.State = Unactivated then + C.Common.Activator := null; + C.Common.State := Terminated; + C.Callable := False; + Cancel_Queued_Entry_Calls (C); + + elsif C.Common.Activator /= null then + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + P := C.Common.Activation_Link; + C.Common.Activation_Link := null; + C := P; + end loop; + + -- Wait for the activated tasks to complete activation. + -- It is unsafe to abort any of these tasks until the count goes to + -- zero. + + loop + Initialization.Poll_Base_Priority_Change (Self_ID); + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Activator_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + -- Remove the tasks from the chain. + + Chain_Access.T_ID := null; + Initialization.Undefer_Abort_Nestable (Self_ID); + + if Self_ID.Common.Activation_Failed then + Self_ID.Common.Activation_Failed := False; + Raise_Exception (Tasking_Error'Identity, + "Failure during activation"); + end if; + end Activate_Tasks; + + ------------------------- + -- Complete_Activation -- + ------------------------- + + procedure Complete_Activation is + Self_ID : constant Task_ID := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + Vulnerable_Complete_Activation (Self_ID); + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- ????? + -- Why do we need to allow for nested deferral here? + + end Complete_Activation; + + --------------------- + -- Complete_Master -- + --------------------- + + procedure Complete_Master is + Self_ID : Task_ID := STPO.Self; + + begin + pragma Assert (Self_ID.Deferral_Level > 0); + + Vulnerable_Complete_Master (Self_ID); + end Complete_Master; + + ------------------- + -- Complete_Task -- + ------------------- + + -- See comments on Vulnerable_Complete_Task for details. + + procedure Complete_Task is + Self_ID : constant Task_ID := STPO.Self; + + begin + pragma Assert (Self_ID.Deferral_Level > 0); + + Vulnerable_Complete_Task (Self_ID); + + -- All of our dependents have terminated. + -- Never undefer abort again! + + end Complete_Task; + + ----------------- + -- Create_Task -- + ----------------- + + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task. + + procedure Create_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + Num_Entries : Task_Entry_Index; + Master : Master_Level; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : System.Task_Info.Task_Image_Type; + Created_Task : out Task_ID) + is + T, P : Task_ID; + Self_ID : constant Task_ID := STPO.Self; + Success : Boolean; + Base_Priority : System.Any_Priority; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Create_Task", 'C')); + + if Priority = Unspecified_Priority then + Base_Priority := Self_ID.Common.Base_Priority; + else + Base_Priority := System.Any_Priority (Priority); + end if; + + -- Find parent P of new Task, via master level number. + + P := Self_ID; + + if P /= null then + while P.Master_of_Task >= Master loop + P := P.Common.Parent; + exit when P = null; + end loop; + end if; + + Initialization.Defer_Abort_Nestable (Self_ID); + + begin + T := New_ATCB (Num_Entries); + + exception + when others => + Initialization.Undefer_Abort_Nestable (Self_ID); + Raise_Exception (Storage_Error'Identity, "Cannot allocate task"); + end; + + -- All_Tasks_L is used by Abort_Dependents and Abort_Tasks. + -- Up to this point, it is possible that we may be part of + -- a family of tasks that is being aborted. + + Lock_All_Tasks_List; + Write_Lock (Self_ID); + + -- Now, we must check that we have not been aborted. + -- If so, we should give up on creating this task, + -- and simply return. + + if not Self_ID.Callable then + pragma Assert (Self_ID.Pending_ATC_Level = 0); + pragma Assert (Self_ID.Pending_Action); + pragma Assert (Chain.T_ID = null + or else Chain.T_ID.Common.State = Unactivated); + + Unlock (Self_ID); + Unlock_All_Tasks_List; + Initialization.Undefer_Abort_Nestable (Self_ID); + + -- ??? Should never get here + + pragma Assert (False); + raise Standard'Abort_Signal; + end if; + + Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, + Base_Priority, Task_Info, Size, T, Success); + + if not Success then + Unlock (Self_ID); + Unlock_All_Tasks_List; + Initialization.Undefer_Abort_Nestable (Self_ID); + Raise_Exception + (Storage_Error'Identity, "Failed to initialize task"); + end if; + + T.Master_of_Task := Master; + T.Master_Within := T.Master_of_Task + 1; + + for L in T.Entry_Calls'Range loop + T.Entry_Calls (L).Self := T; + T.Entry_Calls (L).Level := L; + end loop; + + T.Common.Task_Image := Task_Image; + Unlock (Self_ID); + Unlock_All_Tasks_List; + + -- Create TSD as early as possible in the creation of a task, since it + -- may be used by the operation of Ada code within the task. + + SSL.Create_TSD (T.Common.Compiler_Data); + T.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := T; + Initialization.Initialize_Attributes_Link.all (T); + Created_Task := T; + Initialization.Undefer_Abort_Nestable (Self_ID); + end Create_Task; + + -------------------- + -- Current_Master -- + -------------------- + + function Current_Master return Master_Level is + Self_ID : constant Task_ID := STPO.Self; + + begin + return Self_ID.Master_Within; + end Current_Master; + + ------------------ + -- Enter_Master -- + ------------------ + + procedure Enter_Master is + Self_ID : constant Task_ID := STPO.Self; + + begin + Self_ID.Master_Within := Self_ID.Master_Within + 1; + end Enter_Master; + + ------------------------------- + -- Expunge_Unactivated_Tasks -- + ------------------------------- + + -- See procedure Close_Entries for the general case. + + procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is + Self_ID : constant Task_ID := STPO.Self; + C : Task_ID; + Call : Entry_Call_Link; + Temp : Task_ID; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- ???? + -- Experimentation has shown that abort is sometimes (but not + -- always) already deferred when this is called. + -- That may indicate an error. Find out what is going on. + + C := Chain.T_ID; + + while C /= null loop + pragma Assert (C.Common.State = Unactivated); + + Temp := C.Common.Activation_Link; + + if C.Common.State = Unactivated then + Write_Lock (C); + + for J in 1 .. C.Entry_Num loop + Queuing.Dequeue_Head (C.Entry_Queues (J), Call); + pragma Assert (Call = null); + end loop; + + Unlock (C); + Initialization.Remove_From_All_Tasks_List (C); + Vulnerable_Free_Task (C); + C := Temp; + end if; + end loop; + + Chain.T_ID := null; + Initialization.Undefer_Abort_Nestable (Self_ID); + end Expunge_Unactivated_Tasks; + + --------------------------- + -- Finalize_Global_Tasks -- + --------------------------- + + -- ???? + -- We have a potential problem here if finalization of global + -- objects does anything with signals or the timer server, since + -- by that time those servers have terminated. + + -- It is hard to see how that would occur. + + -- However, a better solution might be to do all this finalization + -- using the global finalization chain. + + procedure Finalize_Global_Tasks is + Self_ID : constant Task_ID := STPO.Self; + Zero_Independent : Boolean; + + begin + if Self_ID.Deferral_Level = 0 then + + -- ?????? + -- In principle, we should be able to predict whether + -- abort is already deferred here (and it should not be deferred + -- yet but in practice it seems Finalize_Global_Tasks is being + -- called sometimes, from RTS code for exceptions, with abort already + -- deferred. + + Initialization.Defer_Abort_Nestable (Self_ID); + + -- Never undefer again!!! + + end if; + + -- This code is only executed by the environment task + + pragma Assert (Self_ID = Environment_Task); + + -- Set Environment_Task'Callable to false to notify library-level tasks + -- that it is waiting for them (cf 5619-003). + + Self_ID.Callable := False; + + -- Exit level 2 master, for normal tasks in library-level packages. + + Complete_Master; + + -- Force termination of "independent" library-level server tasks. + + Abort_Dependents (Self_ID); + + -- We need to explicitely wait for the task to be + -- terminated here because on true concurrent system, we + -- may end this procedure before the tasks are really + -- terminated. + + loop + Write_Lock (Self_ID); + Zero_Independent := Utilities.Independent_Task_Count = 0; + Unlock (Self_ID); + + -- We used to yield here, but this did not take into account + -- low priority tasks that would cause dead lock in some cases. + -- See 8126-020. + + Timed_Delay (Self_ID, 0.01, System.OS_Primitives.Relative); + exit when Zero_Independent; + end loop; + + -- ??? On multi-processor environments, it seems that the above loop + -- isn't sufficient, so we need to add an additional delay. + + Timed_Delay (Self_ID, 0.1, System.OS_Primitives.Relative); + + -- Complete the environment task. + + Vulnerable_Complete_Task (Self_ID); + + System.Finalization_Implementation.Finalize_Global_List; + + SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; + SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; + SSL.Lock_Task := SSL.Task_Lock_NT'Access; + SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; + SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; + SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; + SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; + SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; + SSL.Get_Exc_Stack_Addr := SSL.Get_Exc_Stack_Addr_NT'Access; + SSL.Set_Exc_Stack_Addr := SSL.Set_Exc_Stack_Addr_NT'Access; + SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; + SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; + + -- Don't bother trying to finalize Initialization.Global_Task_Lock + -- and System.Task_Primitives.All_Tasks_L. + end Finalize_Global_Tasks; + + --------------- + -- Free_Task -- + --------------- + + procedure Free_Task (T : Task_ID) is + Self_Id : constant Task_ID := Self; + + begin + if T.Common.State = Terminated then + + -- It is not safe to call Abort_Defer or Write_Lock at this stage + + Initialization.Task_Lock (Self_Id); + + if T.Common.Task_Image /= null then + Free_Task_Image (T.Common.Task_Image); + end if; + + Initialization.Remove_From_All_Tasks_List (T); + Initialization.Task_Unlock (Self_Id); + + System.Task_Primitives.Operations.Finalize_TCB (T); + + -- If the task is not terminated, then we simply ignore the call. This + -- happens when a user program attempts an unchecked deallocation on + -- a non-terminated task. + + else + null; + end if; + end Free_Task; + + ---------------------- + -- Notify_Exception -- + ---------------------- + + procedure Notify_Exception + (Self_Id : Task_ID; + Excep : Exception_Occurrence) + is + procedure To_Stderr (S : String); + pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); + + use System.Task_Info; + use System.Soft_Links; + + function To_Address is new + Unchecked_Conversion (Task_ID, System.Address); + + function Tailored_Exception_Information + (E : Exception_Occurrence) return String; + pragma Import + (Ada, Tailored_Exception_Information, + "__gnat_tailored_exception_information"); + + begin + To_Stderr ("task "); + + if Self_Id.Common.Task_Image /= null then + To_Stderr (Self_Id.Common.Task_Image.all); + To_Stderr ("_"); + end if; + + To_Stderr (System.Address_Image (To_Address (Self_Id))); + To_Stderr (" terminated by unhandled exception"); + To_Stderr ((1 => ASCII.LF)); + To_Stderr (Tailored_Exception_Information (Excep)); + end Notify_Exception; + + ------------------ + -- Task_Wrapper -- + ------------------ + + -- The task wrapper is a procedure that is called first for each task + -- task body, and which in turn calls the compiler-generated task body + -- procedure. The wrapper's main job is to do initialization for the task. + -- It also has some locally declared objects that server as per-task local + -- data. Task finalization is done by Complete_Task, which is called from + -- an at-end handler that the compiler generates. + + -- The variable ID in the task wrapper is used to implement the Self + -- function on targets where there is a fast way to find the stack base + -- of the current thread, since it should be at a fixed offset from the + -- stack base. + + -- The variable Magic_Number is also used in such implementations + -- of Self, to check whether the current task is an Ada task, as + -- compared to other-language threads. + + -- Both act as constants, once initialized, but need to be marked as + -- volatile or aliased to prevent the compiler from optimizing away the + -- storage. See System.Task_Primitives.Operations.Self for more info. + + procedure Task_Wrapper (Self_ID : Task_ID) is + ID : Task_ID := Self_ID; + pragma Volatile (ID); + -- Do not delete this variable. + -- In some targets, we need this variable to implement a fast Self. + + Magic_Number : Interfaces.C.unsigned := 16#ADAADAAD#; + pragma Volatile (Magic_Number); + -- We use this to verify that we are looking at an Ada task, + -- inside of System.Task_Primitives.Operations.Self. + + use type System.Parameters.Size_Type; + use type SSE.Storage_Offset; + use System.Standard_Library; + + Secondary_Stack : aliased SSE.Storage_Array + (1 .. ID.Common.Compiler_Data.Pri_Stack_Info.Size * + SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100); + Secondary_Stack_Address : System.Address := Secondary_Stack'Address; + + begin + pragma Assert (Self_ID.Deferral_Level = 1); + + if not Parameters.Sec_Stack_Dynamic then + ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address; + SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); + end if; + + -- Set the guard page at the bottom of the stack. + -- The call to unprotect the page is done in Terminate_Task + + Stack_Guard (Self_ID, True); + + -- Initialize low-level TCB components, that + -- cannot be initialized by the creator. + -- Enter_Task sets Self_ID.Known_Tasks_Index + -- and Self_ID.LL.Thread + + Enter_Task (Self_ID); + + -- We lock All_Tasks_L to wait for activator to finish activating + -- the rest of the chain, so that everyone in the chain comes out + -- in priority order. + -- This also protects the value of + -- Self_ID.Common.Activator.Common.Wait_Count. + + Lock_All_Tasks_List; + Unlock_All_Tasks_List; + + begin + -- We are separating the following portion of the code in order to + -- place the exception handlers in a different block. + -- In this way we do not call Set_Jmpbuf_Address (which needs + -- Self) before we set Self in Enter_Task + + -- Call the task body procedure. + + -- The task body is called with abort still deferred. That + -- eliminates a dangerous window, for which we had to patch-up in + -- Terminate_Task. + -- During the expansion of the task body, we insert an RTS-call + -- to Abort_Undefer, at the first point where abort should be + -- allowed. + + Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); + + Terminate_Task (Self_ID); + + exception + when Standard'Abort_Signal => + Terminate_Task (Self_ID); + + when others => + -- ??? Using an E : others here causes CD2C11A to fail on + -- DEC Unix, see 7925-005. + + if Exception_Trace = Unhandled_Raise then + Notify_Exception (Self_ID, SSL.Get_Current_Excep.all.all); + end if; + + Terminate_Task (Self_ID); + end; + end Task_Wrapper; + + -------------------- + -- Terminate_Task -- + -------------------- + + -- Before we allow the thread to exit, we must clean up. This is a + -- a delicate job. We must wake up the task's master, who may immediately + -- try to deallocate the ATCB out from under the current task WHILE IT IS + -- STILL EXECUTING. + + -- To avoid this, the parent task must be blocked up to the last thing + -- done before the call to Exit_Task. The trouble is that we have another + -- step that we also want to postpone to the very end, i.e., calling + -- SSL.Destroy_TSD. We have to postpone that until the end because + -- compiler-generated code is likely to try to access that data at just + -- about any point. + + -- We can't call Destroy_TSD while we are holding any other locks, because + -- it locks Global_Task_Lock, and our deadlock prevention rules require + -- that to be the outermost lock. Our first "solution" was to just lock + -- Global_Task_Lock in addition to the other locks, and force the parent + -- to also lock this lock between its wakeup and its freeing of the ATCB. + -- See Complete_Task for the parent-side of the code that has the matching + -- calls to Task_Lock and Task_Unlock. That was not really a solution, + -- since the operation Task_Unlock continued to access the ATCB after + -- unlocking, after which the parent was observed to race ahead, + -- deallocate the ATCB, and then reallocate it to another task. The + -- call to Undefer_Abortion in Task_Unlock by the "terminated" task was + -- overwriting the data of the new task that reused the ATCB! To solve + -- this problem, we introduced the new operation Final_Task_Unlock. + + procedure Terminate_Task (Self_ID : Task_ID) is + Environment_Task : constant Task_ID := STPO.Environment_Task; + + begin + pragma Assert (Self_ID.Common.Activator = null); + + -- Since GCC cannot allocate stack chunks efficiently without reordering + -- some of the allocations, we have to handle this unexpected situation + -- here. We should normally never have to call Vulnerable_Complete_Task + -- here. See 6602-003 for more details. + + if Self_ID.Common.Activator /= null then + Vulnerable_Complete_Task (Self_ID); + end if; + + -- Check if the current task is an independent task + -- If so, decrement the Independent_Task_Count value. + + if Self_ID.Master_of_Task = 2 then + Write_Lock (Environment_Task); + Utilities.Independent_Task_Count := + Utilities.Independent_Task_Count - 1; + Unlock (Environment_Task); + end if; + + -- Unprotect the guard page if needed. + + Stack_Guard (Self_ID, False); + + Initialization.Task_Lock (Self_ID); + Utilities.Make_Passive (Self_ID, Task_Completed => True); + + pragma Assert (Check_Exit (Self_ID)); + + SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); + Initialization.Final_Task_Unlock (Self_ID); + + -- WARNING + -- past this point, this thread must assume that the ATCB + -- has been deallocated. It should not be accessed again. + + STPO.Exit_Task; + end Terminate_Task; + + ---------------- + -- Terminated -- + ---------------- + + function Terminated (T : Task_ID) return Boolean is + Result : Boolean; + Self_ID : Task_ID := STPO.Self; + + begin + Initialization.Defer_Abort_Nestable (Self_ID); + Write_Lock (T); + Result := T.Common.State = Terminated; + Unlock (T); + Initialization.Undefer_Abort_Nestable (Self_ID); + return Result; + end Terminated; + + ------------------------------------ + -- Vulnerable_Complete_Activation -- + ------------------------------------ + + -- Only call this procedure with abortion deferred. + + -- As in several other places, the locks of the activator and activated + -- task are both locked here. This follows our deadlock prevention lock + -- ordering policy, since the activated task must be created after the + -- activator. + + procedure Vulnerable_Complete_Activation (Self_ID : Task_ID) is + Activator : Task_ID := Self_ID.Common.Activator; + + begin + pragma Debug + (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); + + Write_Lock (Activator); + Write_Lock (Self_ID); + + pragma Assert (Self_ID.Common.Activator /= null); + + -- Remove dangling reference to Activator, + -- since a task may outlive its activator. + + Self_ID.Common.Activator := null; + + -- Wake up the activator, if it is waiting for a chain + -- of tasks to activate, and we are the last in the chain + -- to complete activation + + if Activator.Common.State = Activator_Sleep then + Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; + + if Activator.Common.Wait_Count = 0 then + Wakeup (Activator, Activator_Sleep); + end if; + end if; + + -- The activator raises a Tasking_Error if any task + -- it is activating is completed before the activation is + -- done. However, if the reason for the task completion is + -- an abortion, we do not raise an exception. ARM 9.2(5). + + if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then + Activator.Common.Activation_Failed := True; + end if; + + Unlock (Self_ID); + Unlock (Activator); + + -- After the activation, active priority should be the same + -- as base priority. We must unlock the Activator first, + -- though, since it should not wait if we have lower priority. + + if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then + Write_Lock (Self_ID); + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + Unlock (Self_ID); + end if; + end Vulnerable_Complete_Activation; + + -------------------------------- + -- Vulnerable_Complete_Master -- + -------------------------------- + + procedure Vulnerable_Complete_Master (Self_ID : Task_ID) is + C : Task_ID; + P : Task_ID; + CM : Master_Level := Self_ID.Master_Within; + T : aliased Task_ID; + + To_Be_Freed : Task_ID; + -- This is a list of ATCBs to be freed, after we have released + -- all RTS locks. This is necessary because of the locking order + -- rules, since the storage manager uses Global_Task_Lock. + + pragma Warnings (Off); + function Check_Unactivated_Tasks return Boolean; + pragma Warnings (On); + -- Temporary error-checking code below. This is part of the checks + -- added in the new run time. Call it only inside a pragma Assert. + + function Check_Unactivated_Tasks return Boolean is + begin + Lock_All_Tasks_List; + Write_Lock (Self_ID); + C := All_Tasks_List; + + while C /= null loop + if C.Common.Activator = Self_ID then + return False; + end if; + + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + if C.Common.State = Unactivated then + return False; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Unlock (Self_ID); + Unlock_All_Tasks_List; + return True; + end Check_Unactivated_Tasks; + + -- Start of processing for Vulnerable_Complete_Master + + begin + + pragma Debug + (Debug.Trace (Self_ID, "V_Complete_Master", 'C')); + + pragma Assert (Self_ID.Common.Wait_Count = 0); + pragma Assert (Self_ID.Deferral_Level > 0); + + -- Count how many active dependent tasks this master currently + -- has, and record this in Wait_Count. + + -- This count should start at zero, since it is initialized to + -- zero for new tasks, and the task should not exit the + -- sleep-loops that use this count until the count reaches zero. + + Lock_All_Tasks_List; + Write_Lock (Self_ID); + C := All_Tasks_List; + + while C /= null loop + if C.Common.Activator = Self_ID then + pragma Assert (C.Common.State = Unactivated); + + Write_Lock (C); + C.Common.Activator := null; + C.Common.State := Terminated; + C.Callable := False; + Cancel_Queued_Entry_Calls (C); + Unlock (C); + end if; + + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + if C.Awake_Count /= 0 then + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Common.State := Master_Completion_Sleep; + Unlock (Self_ID); + Unlock_All_Tasks_List; + + -- Wait until dependent tasks are all terminated or ready to terminate. + -- While waiting, the task may be awakened if the task's priority needs + -- changing, or this master is aborted. In the latter case, we want + -- to abort the dependents, and resume waiting until Wait_Count goes + -- to zero. + + Write_Lock (Self_ID); + loop + Initialization.Poll_Base_Priority_Change (Self_ID); + exit when Self_ID.Common.Wait_Count = 0; + + -- Here is a difference as compared to Complete_Master + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Dependents_Aborted + then + Unlock (Self_ID); + Abort_Dependents (Self_ID); + Write_Lock (Self_ID); + + else + Sleep (Self_ID, Master_Completion_Sleep); + end if; + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + + -- Dependents are all terminated or on terminate alternatives. + -- Now, force those on terminate alternatives to terminate, by + -- aborting them. + + pragma Assert (Check_Unactivated_Tasks); + + if Self_ID.Alive_Count > 1 then + + -- ????? + -- Consider finding a way to skip the following extra steps if + -- there are no dependents with terminate alternatives. This + -- could be done by adding another count to the ATCB, similar to + -- Awake_Count, but keeping track of count of tasks that are on + -- terminate alternatives. + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + -- Force any remaining dependents to terminate, by aborting them. + + Abort_Dependents (Self_ID); + + -- Above, when we "abort" the dependents we are simply using this + -- operation for convenience. We are not required to support the full + -- abort-statement semantics; in particular, we are not required to + -- immediately cancel any queued or in-service entry calls. That is + -- good, because if we tried to cancel a call we would need to lock + -- the caller, in order to wake the caller up. Our anti-deadlock + -- rules prevent us from doing that without releasing the locks on C + -- and Self_ID. Releasing and retaking those locks would be + -- wasteful, at best, and should not be considered further without + -- more detailed analysis of potential concurrent accesses to the + -- ATCBs of C and Self_ID. + + -- Count how many "alive" dependent tasks this master currently + -- has, and record this in Wait_Count. + -- This count should start at zero, since it is initialized to + -- zero for new tasks, and the task should not exit the + -- sleep-loops that use this count until the count reaches zero. + + pragma Assert (Self_ID.Common.Wait_Count = 0); + + Lock_All_Tasks_List; + Write_Lock (Self_ID); + C := All_Tasks_List; + + while C /= null loop + if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then + Write_Lock (C); + + pragma Assert (C.Awake_Count = 0); + + if C.Alive_Count > 0 then + pragma Assert (C.Terminate_Alternative); + Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; + end if; + + Unlock (C); + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Self_ID.Common.State := Master_Phase_2_Sleep; + Unlock (Self_ID); + Unlock_All_Tasks_List; + + -- Wait for all counted tasks to finish terminating themselves. + + Write_Lock (Self_ID); + + loop + Initialization.Poll_Base_Priority_Change (Self_ID); + exit when Self_ID.Common.Wait_Count = 0; + Sleep (Self_ID, Master_Phase_2_Sleep); + end loop; + + Self_ID.Common.State := Runnable; + Unlock (Self_ID); + end if; + + -- We don't wake up for abortion here. We are already terminating + -- just as fast as we can, so there is no point. + -- ???? + -- Consider whether we want to bother checking for priority + -- changes in the loop above, though. + + -- Remove terminated tasks from the list of Self_ID's dependents, but + -- don't free their ATCBs yet, because of lock order restrictions, + -- which don't allow us to call "free" or "malloc" while holding any + -- other locks. Instead, we put those ATCBs to be freed onto a + -- temporary list, called To_Be_Freed. + + Lock_All_Tasks_List; + C := All_Tasks_List; + P := null; + + while C /= null loop + if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then + if P /= null then + P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; + else + All_Tasks_List := C.Common.All_Tasks_Link; + end if; + + T := C.Common.All_Tasks_Link; + C.Common.All_Tasks_Link := To_Be_Freed; + To_Be_Freed := C; + C := T; + + else + P := C; + C := C.Common.All_Tasks_Link; + end if; + end loop; + + Unlock_All_Tasks_List; + + -- Free all the ATCBs on the list To_Be_Freed. + + -- The ATCBs in the list are no longer in All_Tasks_List, and after + -- any interrupt entries are detached from them they should no longer + -- be referenced. + + -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to + -- avoid a race between a terminating task and its parent. The parent + -- might try to deallocate the ACTB out from underneath the exiting + -- task. Note that Free will also lock Global_Task_Lock, but that is + -- OK, since this is the *one* lock for which we have a mechanism to + -- support nested locking. See Task_Wrapper and its finalizer for more + -- explanation. + + -- ??? + -- The check "T.Common.Parent /= null ..." below is to prevent dangling + -- references to terminated library-level tasks, which could + -- otherwise occur during finalization of library-level objects. + -- A better solution might be to hook task objects into the + -- finalization chain and deallocate the ATCB when the task + -- object is deallocated. However, this change is not likely + -- to gain anything significant, since all this storage should + -- be recovered en-masse when the process exits. + + while To_Be_Freed /= null loop + T := To_Be_Freed; + To_Be_Freed := T.Common.All_Tasks_Link; + + -- ??? On SGI there is currently no Interrupt_Manager, that's + -- why we need to check if the Interrupt_Manager_ID is null + + if T.Interrupt_Entry and Interrupt_Manager_ID /= null then + declare + Detach_Interrupt_Entries_Index : Task_Entry_Index := 6; + -- Corresponds to the entry index of System.Interrupts. + -- Interrupt_Manager.Detach_Interrupt_Entries. + -- Be sure to update this value when changing + -- Interrupt_Manager specs. + + type Param_Type is access all Task_ID; + Param : aliased Param_Type := T'Access; + begin + System.Tasking.Rendezvous.Call_Simple + (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, + Param'Address); + end; + end if; + + if (T.Common.Parent /= null + and then T.Common.Parent.Common.Parent /= null) + or else T.Master_of_Task > 3 + then + Initialization.Task_Lock (Self_ID); + + -- If Sec_Stack_Addr is not null, it means that Destroy_TSD + -- has not been called yet (case of an unactivated task). + + if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then + SSL.Destroy_TSD (T.Common.Compiler_Data); + end if; + + Vulnerable_Free_Task (T); + Initialization.Task_Unlock (Self_ID); + end if; + end loop; + + -- It might seem nice to let the terminated task deallocate + -- its own ATCB. That would not cover the case of unactivated + -- tasks. It also would force us to keep the underlying thread + -- around past termination, since references to the ATCB are + -- possible past termination. Currently, we get rid of the + -- thread as soon as the task terminates, and let the parent + -- recover the ATCB later. + + -- ???? + -- Some day, if we want to recover the ATCB earlier, at task + -- termination, we could consider using "fat task IDs", that + -- include the serial number with the ATCB pointer, to catch + -- references to tasks that no longer have ATCBs. It is not + -- clear how much this would gain, since the user-level task + -- object would still be occupying storage. + + -- Make next master level up active. + -- We don't need to lock the ATCB, since the value is only + -- updated by each task for itself. + + Self_ID.Master_Within := CM - 1; + end Vulnerable_Complete_Master; + + ------------------------------ + -- Vulnerable_Complete_Task -- + ------------------------------ + + -- Complete the calling task. + + -- This procedure must be called with abort deferred. (That's why the + -- name has "Vulnerable" in it.) It should only be called by Complete_Task + -- and Finalizate_Global_Tasks (for the environment task). + + -- The effect is similar to that of Complete_Master. Differences include + -- the closing of entries here, and computation of the number of active + -- dependent tasks in Complete_Master. + + -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, + -- because that does its own locking, and because we do not need the lock + -- to test Self_ID.Common.Activator. That value should only be read and + -- modified by Self. + + procedure Vulnerable_Complete_Task (Self_ID : Task_ID) is + begin + pragma Assert (Self_ID.Deferral_Level > 0); + pragma Assert (Self_ID = Self); + pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 + or else + Self_ID.Master_Within = Self_ID.Master_of_Task + 2); + pragma Assert (Self_ID.Common.Wait_Count = 0); + pragma Assert (Self_ID.Open_Accepts = null); + pragma Assert (Self_ID.ATC_Nesting_Level = 1); + + pragma Debug + (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); + + Write_Lock (Self_ID); + Self_ID.Callable := False; + + -- In theory, Self should have no pending entry calls + -- left on its call-stack. Each async. select statement should + -- clean its own call, and blocking entry calls should + -- defer abort until the calls are cancelled, then clean up. + + Cancel_Queued_Entry_Calls (Self_ID); + Unlock (Self_ID); + + if Self_ID.Common.Activator /= null then + Vulnerable_Complete_Activation (Self_ID); + end if; + + -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 + -- we may have dependent tasks for which we need to wait. + -- Otherwise, we can just exit. + + if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then + Vulnerable_Complete_Master (Self_ID); + end if; + + end Vulnerable_Complete_Task; + + -------------------------- + -- Vulnerable_Free_Task -- + -------------------------- + + -- Recover all runtime system storage associated with the task T. + -- This should only be called after T has terminated and will no + -- longer be referenced. + -- For tasks created by an allocator that fails, due to an exception, + -- it is called from Expunge_Unactivated_Tasks. + -- For tasks created by elaboration of task object declarations it + -- is called from the finalization code of the Task_Wrapper procedure. + -- It is also called from Unchecked_Deallocation, for objects that + -- are or contain tasks. + + procedure Vulnerable_Free_Task (T : Task_ID) is + begin + pragma Debug + (Debug.Trace ("Vulnerable_Free_Task", T, 'C')); + + Write_Lock (T); + Initialization.Finalize_Attributes_Link.all (T); + Unlock (T); + if T.Common.Task_Image /= null then + Free_Task_Image (T.Common.Task_Image); + end if; + System.Task_Primitives.Operations.Finalize_TCB (T); + end Vulnerable_Free_Task; + +begin + -- Establish the Adafinal softlink. + -- This is not done inside the central RTS initialization routine + -- to avoid with-ing this package from System.Tasking.Initialization. + + SSL.Adafinal := Finalize_Global_Tasks'Access; + + -- Establish soft links for subprograms that manipulate master_id's. + -- This cannot be done when the RTS is initialized, because of various + -- elaboration constraints. + + SSL.Current_Master := Stages.Current_Master'Access; + SSL.Enter_Master := Stages.Enter_Master'Access; + SSL.Complete_Master := Stages.Complete_Master'Access; +end System.Tasking.Stages; diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads new file mode 100644 index 00000000000..913435a03fb --- /dev/null +++ b/gcc/ada/s-tassta.ads @@ -0,0 +1,274 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . S T A G E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.33 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package represents the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) + +-- Note: Only the compiler is allowed to use this interface, by generating +-- direct calls to it, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +with System.Task_Info; +-- used for Task_Info_Type + +with System.Parameters; +-- used for Size_Type + +package System.Tasking.Stages is + pragma Elaborate_Body; + + -- The compiler will expand in the GNAT tree the following construct: + -- + -- task type T (Discr : Integer); + -- + -- task body T is + -- ...declarations, possibly some controlled... + -- begin + -- ...B...; + -- end T; + -- + -- T1 : T (1); + -- + -- as follows: + -- + -- enter_master.all; + -- + -- _chain : aliased activation_chain; + -- _init_proc (_chain); + -- + -- task type t (discr : integer); + -- tE : aliased boolean := false; + -- tZ : size_type := unspecified_size; + -- type tV (discr : integer) is limited record + -- _task_id : task_id; + -- end record; + -- procedure tB (_task : access tV); + -- freeze tV [ + -- procedure _init_proc (_init : in out tV; _master : master_id; + -- _chain : in out activation_chain; _task_id : in task_image_type; + -- discr : integer) is + -- begin + -- _init.discr := discr; + -- _init._task_id := null; + -- create_task (unspecified_priority, tZ, + -- unspecified_task_info, 0, _master, + -- task_procedure_access!(tB'address), + -- _init'address, tE'unchecked_access, _chain, _task_id, _init. + -- _task_id); + -- return; + -- end _init_proc; + -- ] + -- + -- procedure tB (_task : access tV) is + -- discr : integer renames _task.discr; + -- + -- procedure _clean is + -- begin + -- abort_defer.all; + -- complete_task; + -- finalize_list (F14b); + -- abort_undefer.all; + -- return; + -- end _clean; + -- begin + -- abort_undefer.all; + -- ...declarations... + -- complete_activation; + -- ...B...; + -- return; + -- at end + -- _clean; + -- end tB; + -- + -- tE := true; + -- t1 : t (1); + -- master : constant master_id := current_master.all; + -- t1I : task_image_type := new string'"t1"; + -- _init_proc (t1, _master, _chain, t1I, 1); + -- + -- activate_tasks (_chain'unchecked_access); + + procedure Abort_Tasks (Tasks : Task_List); + -- Compiler interface only. Do not call from within the RTS. + -- Initiate abortion, however, the actual abortion is done by abortee by + -- means of Abort_Handler and Abort_Undefer + -- + -- source code: + -- Abort T1, T2; + -- code expansion: + -- abort_tasks (task_list'(t1._task_id, t2._task_id)); + + procedure Activate_Tasks (Chain_Access : Activation_Chain_Access); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the creator of a chain of one or more new tasks, + -- to activate them. The chain is a linked list that up to this point is + -- only known to the task that created them, though the individual tasks + -- are already in the All_Tasks_List. + -- + -- The compiler builds the chain in LIFO order (as a stack). Another + -- version of this procedure had code to reverse the chain, so as to + -- activate the tasks in the order of declaration. This might be nice, but + -- it is not needed if priority-based scheduling is supported, since all + -- the activated tasks synchronize on the activators lock before they + -- start activating and so they should start activating in priority order. + + procedure Complete_Activation; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from the task body at the end of + -- the elaboration code for its declarative part. + -- Decrement the count of tasks to be activated by the activator and + -- wake it up so it can check to see if all tasks have been activated. + -- Except for the environment task, which should never call this procedure, + -- T.Activator should only be null iff T has completed activation. + + procedure Complete_Master; + -- Compiler interface only. Do not call from within the RTS. This must + -- be called on exit from any master where Enter_Master was called. + -- Assume abort is deferred at this point. + + procedure Complete_Task; + -- Compiler interface only. Do not call from within the RTS. + -- This should be called from an implicit at-end handler + -- associated with the task body, when it completes. + -- From this point, the current task will become not callable. + -- If the current task have not completed activation, this should be done + -- now in order to wake up the activator (the environment task). + + procedure Create_Task + (Priority : Integer; + Size : System.Parameters.Size_Type; + Task_Info : System.Task_Info.Task_Info_Type; + Num_Entries : Task_Entry_Index; + Master : Master_Level; + State : Task_Procedure_Access; + Discriminants : System.Address; + Elaborated : Access_Boolean; + Chain : in out Activation_Chain; + Task_Image : System.Task_Info.Task_Image_Type; + Created_Task : out Task_ID); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called to create a new task. + -- + -- Priority is the task's priority (assumed to be in the + -- System.Any_Priority'Range) + -- Size is the stack size of the task to create + -- Task_Info is the task info associated with the created task, or + -- Unspecified_Task_Info if none. + -- State is the compiler generated task's procedure body + -- Discriminants is a pointer to a limited record whose discriminants + -- are those of the task to create. This parameter should be passed as + -- the single argument to State. + -- Elaborated is a pointer to a Boolean that must be set to true on exit + -- if the task could be sucessfully elaborated. + -- Chain is a linked list of task that needs to be created. On exit, + -- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID + -- will be Created_Task (e.g the created task will be linked at the front + -- of Chain). + -- Task_Image is a pointer to a string created by the compiler that the + -- run time can store to ease the debugging and the + -- Ada.Task_Identification facility. + -- Created_Task is the resulting task. + -- + -- This procedure can raise Storage_Error if the task creation failed. + + function Current_Master return Master_Level; + -- Compiler interface only. + -- This is called to obtain the current master nesting level. + + procedure Enter_Master; + -- Compiler interface only. Do not call from within the RTS. + -- This must be called on entry to any "master" where a task, + -- or access type designating objects containing tasks, may be + -- declared. + + procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain); + -- Compiler interface only. Do not call from within the RTS. + -- This must be called by the compiler-generated code for an allocator if + -- the allocated object contains tasks, if the allocator exits without + -- calling Activate_Tasks for a given activation chains, as can happen if + -- an exception occurs during initialization of the object. + -- + -- This should be called ONLY for tasks created via an allocator. Recovery + -- of storage for unactivated local task declarations is done by + -- Complete_Master and Complete_Task. + -- + -- We remove each task from Chain and All_Tasks_List before we free the + -- storage of its ATCB. + -- + -- In other places where we recover the storage of unactivated tasks, we + -- need to clean out the entry queues, but here that should not be + -- necessary, since these tasks should not have been visible to any other + -- tasks, and so no task should be able to queue a call on their entries. + -- + -- Just in case somebody misuses this subprogram, there is a check to + -- verify this condition. + + procedure Finalize_Global_Tasks; + -- This should be called to complete the execution of the environment task + -- and shut down the tasking runtime system. It is the equivalent of + -- Complete_Task, but for the environment task. + -- + -- The environment task must first call Complete_Master, to wait for user + -- tasks that depend on library-level packages to terminate. It then calls + -- Abort_Dependents to abort the "independent" library-level server tasks + -- that are created implicitly by the RTS packages (signal and timer server + -- tasks), and then waits for them to terminate. Then, it calls + -- Vulnerable_Complete_Task. + -- + -- It currently also executes the global finalization list, and then resets + -- the "soft links". + + procedure Free_Task (T : Task_ID); + -- Recover all runtime system storage associated with the task T, but only + -- if T has terminated. Do nothing in the other case. It is called from + -- Unchecked_Deallocation, for objects that are or contain tasks. + + function Terminated (T : Task_ID) return Boolean; + -- This is called by the compiler to implement the 'Terminated attribute. + -- Though is not required to be so by the ARM, we choose to synchronize + -- with the task's ATCB, so that this is more useful for polling the state + -- of a task, and so that it becomes an abort completion point for the + -- calling task (via Undefer_Abort). + -- + -- source code: + -- T1'Terminated + -- + -- code expansion: + -- terminated (t1._task_id) + +end System.Tasking.Stages; diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb new file mode 100644 index 00000000000..af729643c15 --- /dev/null +++ b/gcc/ada/s-tasuti.adb @@ -0,0 +1,570 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . U T I L I T I E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.67 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides RTS Internal Declarations. +-- These declarations are not part of the GNARLI + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.Tasking.Debug; +-- used for Known_Tasks + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Set_Priority +-- Wakeup +-- Unlock +-- Sleep +-- Abort_Task +-- Lock/Unlock_All_Tasks_List + +with System.Tasking.Initialization; +-- Used for Defer_Abort +-- Undefer_Abort +-- Locked_Abort_To_Level + +with System.Tasking.Queuing; +-- used for Dequeue_Call +-- Dequeue_Head + +with System.Tasking.Debug; +-- used for Trace + +with Unchecked_Conversion; + +package body System.Tasking.Utilities is + + package STPO renames System.Task_Primitives.Operations; + + use System.Tasking.Debug; + use System.Task_Primitives; + use System.Task_Primitives.Operations; + + procedure Locked_Abort_To_Level + (Self_Id : Task_ID; + T : Task_ID; + L : ATC_Level) + renames + Initialization.Locked_Abort_To_Level; + + procedure Defer_Abort (Self_Id : Task_ID) renames + System.Tasking.Initialization.Defer_Abort; + + procedure Defer_Abort_Nestable (Self_Id : Task_ID) renames + System.Tasking.Initialization.Defer_Abort_Nestable; + + procedure Undefer_Abort (Self_Id : Task_ID) renames + System.Tasking.Initialization.Undefer_Abort; + + procedure Undefer_Abort_Nestable (Self_Id : Task_ID) renames + System.Tasking.Initialization.Undefer_Abort_Nestable; + + procedure Wakeup_Entry_Caller + (Self_Id : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + renames + Initialization.Wakeup_Entry_Caller; + + ---------------- + -- Abort_Task -- + ---------------- + + -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: + -- (1) caller should be holding no locks + -- (2) may be called for tasks that have not yet been activated + -- (3) always aborts whole task + + procedure Abort_One_Task + (Self_ID : Task_ID; + T : Task_ID) + is + begin + Write_Lock (T); + + if T.Common.State = Unactivated then + T.Common.Activator := null; + T.Common.State := Terminated; + T.Callable := False; + Cancel_Queued_Entry_Calls (T); + + elsif T.Common.State /= Terminated then + Locked_Abort_To_Level (Self_ID, T, 0); + end if; + + Unlock (T); + end Abort_One_Task; + + ----------------- + -- Abort_Tasks -- + ----------------- + + -- Compiler interface only: Do not call from within the RTS, + + -- except in the implementation of Ada.Task_Identification. + -- This must be called to implement the abort statement. + -- Much of the actual work of the abort is done by the abortee, + -- via the Abort_Handler signal handler, and propagation of the + -- Abort_Signal special exception. + + procedure Abort_Tasks (Tasks : Task_List) is + Self_Id : constant Task_ID := STPO.Self; + C : Task_ID; + P : Task_ID; + + begin + -- ???? + -- Since this is a "potentially blocking operation", we should + -- add a separate check here that we are not inside a protected + -- operation. + + Defer_Abort_Nestable (Self_Id); + + -- ????? + -- Really should not be nested deferral here. + -- Patch for code generation error that defers abort before + -- evaluating parameters of an entry call (at least, timed entry + -- calls), and so may propagate an exception that causes abort + -- to remain undeferred indefinitely. See C97404B. When all + -- such bugs are fixed, this patch can be removed. + + for J in Tasks'Range loop + C := Tasks (J); + Abort_One_Task (Self_Id, C); + end loop; + + Lock_All_Tasks_List; + C := All_Tasks_List; + + while C /= null loop + if C.Pending_ATC_Level > 0 then + P := C.Common.Parent; + + while P /= null loop + if P.Pending_ATC_Level = 0 then + Abort_One_Task (Self_Id, C); + exit; + end if; + + P := P.Common.Parent; + end loop; + end if; + + C := C.Common.All_Tasks_Link; + end loop; + + Unlock_All_Tasks_List; + Undefer_Abort_Nestable (Self_Id); + end Abort_Tasks; + + ------------------------------- + -- Cancel_Queued_Entry_Calls -- + ------------------------------- + + -- Cancel any entry calls queued on target task. Call this only while + -- holding T locked, and nothing more. This should only be called by T, + -- unless T is a terminated previously unactivated task. + + procedure Cancel_Queued_Entry_Calls (T : Task_ID) is + Next_Entry_Call : Entry_Call_Link; + Entry_Call : Entry_Call_Link; + Caller : Task_ID; + Level : Integer; + Self_Id : constant Task_ID := STPO.Self; + + begin + pragma Assert (T = Self or else T.Common.State = Terminated); + + for J in 1 .. T.Entry_Num loop + Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); + + while Entry_Call /= null loop + + -- Leave Entry_Call.Done = False, since this is cancelled + + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Tasking_Error'Identity; + Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call); + Level := Entry_Call.Level - 1; + Unlock (T); + Write_Lock (Entry_Call.Self); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); + Unlock (Entry_Call.Self); + Write_Lock (T); + Entry_Call.State := Done; + Entry_Call := Next_Entry_Call; + end loop; + end loop; + end Cancel_Queued_Entry_Calls; + + ------------------------ + -- Exit_One_ATC_Level -- + ------------------------ + + -- Call only with abort deferred and holding lock of Self_Id. + -- This is a bit of common code for all entry calls. + -- The effect is to exit one level of ATC nesting. + + -- If we have reached the desired ATC nesting level, reset the + -- requested level to effective infinity, to allow further calls. + -- In any case, reset Self_Id.Aborting, to allow re-raising of + -- Abort_Signal. + + procedure Exit_One_ATC_Level (Self_ID : Task_ID) is + begin + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + + pragma Debug + (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + + pragma Assert (Self_ID.ATC_Nesting_Level >= 1); + + if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then + if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then + Self_ID.Pending_ATC_Level := ATC_Level_Infinity; + Self_ID.Aborting := False; + else + -- Force the next Undefer_Abort to re-raise Abort_Signal + + pragma Assert + (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level); + + if Self_ID.Aborting then + Self_ID.ATC_Hack := True; + Self_ID.Pending_Action := True; + end if; + end if; + end if; + end Exit_One_ATC_Level; + + ---------------------- + -- Make_Independent -- + ---------------------- + + -- Move the current task to the outermost level (level 2) of the master + -- hierarchy of the environment task. That is one level further out + -- than normal tasks defined in library-level packages (level 3). The + -- environment task will wait for level 3 tasks to terminate normally, + -- then it will abort all the level 2 tasks. See Finalize_Global_Tasks + -- procedure for more information. + + -- This is a dangerous operation, and should only be used on nested tasks + -- or tasks that depend on any objects that might be finalized earlier than + -- the termination of the environment task. It is for internal use by the + -- GNARL, to prevent such internal server tasks from preventing a partition + -- from terminating. + + -- Also note that the run time assumes that the parent of an independent + -- task is the environment task. If this is not the case, Make_Independent + -- will change the task's parent. This assumption is particularly + -- important for master level completion and for the computation of + -- Independent_Task_Count. + + -- See procedures Init_RTS and Finalize_Global_Tasks for related code. + + procedure Make_Independent is + Self_Id : constant Task_ID := STPO.Self; + Environment_Task : constant Task_ID := STPO.Environment_Task; + Parent : constant Task_ID := Self_Id.Common.Parent; + Parent_Needs_Updating : Boolean := False; + + begin + if Self_Id.Known_Tasks_Index /= -1 then + Known_Tasks (Self_Id.Known_Tasks_Index) := null; + end if; + + Defer_Abort (Self_Id); + Write_Lock (Environment_Task); + Write_Lock (Self_Id); + + pragma Assert (Parent = Environment_Task + or else Self_Id.Master_of_Task = Library_Task_Level); + + Self_Id.Master_of_Task := Independent_Task_Level; + + -- The run time assumes that the parent of an independent task is the + -- environment task. + + if Parent /= Environment_Task then + + -- We can not lock three tasks at the same time, so defer the + -- operations on the parent. + + Parent_Needs_Updating := True; + Self_Id.Common.Parent := Environment_Task; + end if; + + -- Update Independent_Task_Count that is needed for the GLADE + -- termination rule. See also pending update in + -- System.Tasking.Stages.Check_Independent + + Independent_Task_Count := Independent_Task_Count + 1; + + Unlock (Self_Id); + + -- Changing the parent after creation is not trivial. Do not forget + -- to update the old parent counts, and the new parent (i.e. the + -- Environment_Task) counts. + + if Parent_Needs_Updating then + Write_Lock (Parent); + Parent.Awake_Count := Parent.Awake_Count - 1; + Parent.Alive_Count := Parent.Alive_Count - 1; + Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1; + Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1; + Unlock (Parent); + end if; + + Unlock (Environment_Task); + Undefer_Abort (Self_Id); + end Make_Independent; + + ------------------ + -- Make_Passive -- + ------------------ + + -- Update counts to indicate current task is either terminated + -- or accepting on a terminate alternative. Call holding no locks. + + procedure Make_Passive + (Self_ID : Task_ID; + Task_Completed : Boolean) + is + C : Task_ID := Self_ID; + P : Task_ID := C.Common.Parent; + + Master_Completion_Phase : Integer; + + begin + if P /= null then + Write_Lock (P); + end if; + + Write_Lock (C); + + if Task_Completed then + Self_ID.Common.State := Terminated; + + if Self_ID.Awake_Count = 0 then + + -- We are completing via a terminate alternative. + -- Our parent should wait in Phase 2 of Complete_Master. + + Master_Completion_Phase := 2; + + pragma Assert (Task_Completed); + pragma Assert (Self_ID.Terminate_Alternative); + pragma Assert (Self_ID.Alive_Count = 1); + + else + -- We are NOT on a terminate alternative. + -- Our parent should wait in Phase 1 of Complete_Master. + + Master_Completion_Phase := 1; + pragma Assert (Self_ID.Awake_Count = 1); + end if; + + -- We are accepting with a terminate alternative. + + else + if Self_ID.Open_Accepts = null then + + -- Somebody started a rendezvous while we had our lock open. + -- Skip the terminate alternative. + + Unlock (C); + + if P /= null then + Unlock (P); + end if; + + return; + end if; + + Self_ID.Terminate_Alternative := True; + Master_Completion_Phase := 0; + + pragma Assert (Self_ID.Terminate_Alternative); + pragma Assert (Self_ID.Awake_Count >= 1); + end if; + + if Master_Completion_Phase = 2 then + + -- Since our Awake_Count is zero but our Alive_Count + -- is nonzero, we have been accepting with a terminate + -- alternative, and we now have been told to terminate + -- by a completed master (in some ancestor task) that + -- is waiting (with zero Awake_Count) in Phase 2 of + -- Complete_Master. + + pragma Debug + (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); + + pragma Assert (P /= null); + + C.Alive_Count := C.Alive_Count - 1; + + if C.Alive_Count > 0 then + Unlock (C); + Unlock (P); + return; + end if; + + -- C's count just went to zero, indicating that + -- all of C's dependents are terminated. + -- C has a parent, P. + + loop + -- C's count just went to zero, indicating that all of C's + -- dependents are terminated. C has a parent, P. Notify P that + -- C and its dependents have all terminated. + + P.Alive_Count := P.Alive_Count - 1; + exit when P.Alive_Count > 0; + Unlock (C); + Unlock (P); + C := P; + P := C.Common.Parent; + + -- Environment task cannot have terminated yet + + pragma Assert (P /= null); + + Write_Lock (P); + Write_Lock (C); + end loop; + + pragma Assert (P.Awake_Count /= 0); + + if P.Common.State = Master_Phase_2_Sleep + and then C.Master_of_Task = P.Master_Within + + then + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; + + if P.Common.Wait_Count = 0 then + Wakeup (P, Master_Phase_2_Sleep); + end if; + end if; + + Unlock (C); + Unlock (P); + return; + end if; + + -- We are terminating in Phase 1 or Complete_Master, + -- or are accepting on a terminate alternative. + + C.Awake_Count := C.Awake_Count - 1; + + if Task_Completed then + pragma Assert (Self_ID.Awake_Count = 0); + C.Alive_Count := C.Alive_Count - 1; + end if; + + if C.Awake_Count > 0 or else P = null then + Unlock (C); + + if P /= null then + Unlock (P); + end if; + + return; + end if; + + -- C's count just went to zero, indicating that all of C's + -- dependents are terminated or accepting with terminate alt. + -- C has a parent, P. + + loop + -- Notify P that C has gone passive. + + P.Awake_Count := P.Awake_Count - 1; + + if Task_Completed and then C.Alive_Count = 0 then + P.Alive_Count := P.Alive_Count - 1; + end if; + + exit when P.Awake_Count > 0; + Unlock (C); + Unlock (P); + C := P; + P := C.Common.Parent; + + if P = null then + return; + end if; + + Write_Lock (P); + Write_Lock (C); + end loop; + + -- P has non-passive dependents. + + if P.Common.State = Master_Completion_Sleep and then + C.Master_of_Task = P.Master_Within + then + pragma Debug + (Debug.Trace + (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); + + -- If parent is in Master_Completion_Sleep, it + -- cannot be on a terminate alternative, hence + -- it cannot have Awake_Count of zero. + + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; + + if P.Common.Wait_Count = 0 then + Wakeup (P, Master_Completion_Sleep); + end if; + + else + pragma Debug + (Debug.Trace + (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); + null; + end if; + + Unlock (C); + Unlock (P); + end Make_Passive; + +end System.Tasking.Utilities; diff --git a/gcc/ada/s-tasuti.ads b/gcc/ada/s-tasuti.ads new file mode 100644 index 00000000000..6d605bc394a --- /dev/null +++ b/gcc/ada/s-tasuti.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . U T I L I T I E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.34 $ -- +-- -- +-- Copyright (C) 1991-1998 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides RTS Internal Declarations. +-- These declarations are not part of the GNARLI + +with Unchecked_Conversion; + +package System.Tasking.Utilities is + + function ATCB_To_Address is new + Unchecked_Conversion (Task_ID, System.Address); + + --------------------------------- + -- Task_Stage Related routines -- + --------------------------------- + + procedure Make_Independent; + -- Move the current task to the outermost level (level 1) of the master + -- master hierarchy of the environment task. This is one level further + -- out than normal tasks defined in library-level packages (level 2). + -- The environment task will wait for level 2 tasks to terminate normally, + -- then it will abort all the level 1 tasks. See Finalize_Global_Tasks + -- procedure for more information. + -- + -- This is a dangerous operation, and should only be used on nested tasks + -- or tasks that depend on any objects that might be finalized earlier than + -- the termination of the environment task. It is for internal use by + -- GNARL, to prevent such internal server tasks from preventing a + -- partition from terminating. + + Independent_Task_Count : Natural := 0; + -- Number of independent task. This counter is incremented each time + -- Make_Independent is called. Note that if a server task terminates, + -- this counter will not be decremented. Since Make_Independent locks + -- the environment task (because every independent task depends on it), + -- this counter is protected by the environment task's lock. + + ------------------------------------ + -- Task Abortion related routines -- + ------------------------------------ + + procedure Cancel_Queued_Entry_Calls (T : Task_ID); + -- Cancel any entry calls queued on target task. + -- Do not call this while holding any locks. + + procedure Exit_One_ATC_Level (Self_ID : Task_ID); + pragma Inline (Exit_One_ATC_Level); + -- Call only with abort deferred and holding lock of Self_ID. + -- This is a bit of common code for all entry calls. + -- The effect is to exit one level of ATC nesting. + + procedure Abort_One_Task + (Self_ID : Task_ID; + T : Task_ID); + -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: + -- (1) caller should be holding no locks + -- (2) may be called for tasks that have not yet been activated + -- (3) always aborts whole task + + procedure Abort_Tasks (Tasks : Task_List); + -- Abort_Tasks is called to initiate abortion, however, the actual + -- abortion is done by abortee by means of Abort_Handler + + procedure Make_Passive + (Self_ID : Task_ID; + Task_Completed : Boolean); + -- Update counts to indicate current task is either terminated + -- or accepting on a terminate alternative. Call holding no locks. + +end System.Tasking.Utilities; diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb new file mode 100644 index 00000000000..a7109fbfd9a --- /dev/null +++ b/gcc/ada/s-tataat.adb @@ -0,0 +1,225 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1995-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.Storage_Elements; +-- used for To_Address + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock +-- Lock/Unlock_All_Tasks_List + +with System.Tasking.Initialization; +-- used for Defer_Abort +-- Undefer_Abort + +with Unchecked_Conversion; + +package body System.Tasking.Task_Attributes is + + use Task_Primitives.Operations, + System.Tasking.Initialization; + + function To_Access_Node is new Unchecked_Conversion + (Access_Address, Access_Node); + -- Tetch pointer to indirect attribute list + + function To_Access_Address is new Unchecked_Conversion + (Access_Node, Access_Address); + -- Store pointer to indirect attribute list + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (X : in out Instance) is + Q, To_Be_Freed : Access_Node; + + begin + Defer_Abortion; + Write_Lock (All_Attrs_L'Access); + + -- Remove this instantiation from the list of all instantiations. + + declare + P : Access_Instance; + Q : Access_Instance := All_Attributes; + + begin + while Q /= null and then Q /= X'Unchecked_Access loop + P := Q; Q := Q.Next; + end loop; + + pragma Assert (Q /= null); + + if P = null then + All_Attributes := Q.Next; + else + P.Next := Q.Next; + end if; + end; + + if X.Index /= 0 then + + -- Free location of this attribute, for reuse. + + In_Use := In_Use and not (2**Natural (X.Index)); + + -- There is no need for finalization in this case, + -- since controlled types are too big to fit in the TCB. + + else + -- Remove nodes for this attribute from the lists of + -- all tasks, and deallocate the nodes. + -- Deallocation does finalization, if necessary. + + Lock_All_Tasks_List; + + declare + C : System.Tasking.Task_ID := All_Tasks_List; + P : Access_Node; + + begin + while C /= null loop + Write_Lock (C); + + Q := To_Access_Node (C.Indirect_Attributes); + while Q /= null + and then Q.Instance /= X'Unchecked_Access + loop + P := Q; + Q := Q.Next; + end loop; + + if Q /= null then + if P = null then + C.Indirect_Attributes := To_Access_Address (Q.Next); + else + P.Next := Q.Next; + end if; + + -- Can't Deallocate now since we are holding the All_Tasks_L + -- lock. + + Q.Next := To_Be_Freed; + To_Be_Freed := Q; + end if; + + Unlock (C); + C := C.Common.All_Tasks_Link; + end loop; + end; + + Unlock_All_Tasks_List; + end if; + + Unlock (All_Attrs_L'Access); + + while To_Be_Freed /= null loop + Q := To_Be_Freed; + To_Be_Freed := To_Be_Freed.Next; + X.Deallocate.all (Q); + end loop; + + Undefer_Abortion; + + exception + when others => null; + pragma Assert (False, + "Exception in task attribute instance finalization"); + end Finalize; + + ------------------------- + -- Finalize Attributes -- + ------------------------- + + -- This is to be called just before the ATCB is deallocated. + -- It relies on the caller holding T.L write-lock on entry. + + procedure Finalize_Attributes (T : Task_ID) is + P : Access_Node; + Q : Access_Node := To_Access_Node (T.Indirect_Attributes); + + begin + -- Deallocate all the indirect attributes of this task. + + while Q /= null loop + P := Q; + Q := Q.Next; P.Instance.Deallocate.all (P); + end loop; + + T.Indirect_Attributes := null; + + exception + when others => null; + pragma Assert (False, + "Exception in per-task attributes finalization"); + end Finalize_Attributes; + + --------------------------- + -- Initialize Attributes -- + --------------------------- + + -- This is to be called by System.Task_Stages.Create_Task. + -- It relies on their being no concurrent access to this TCB, + -- so it does not defer abortion or lock T.L. + + procedure Initialize_Attributes (T : Task_ID) is + P : Access_Instance; + + begin + Write_Lock (All_Attrs_L'Access); + + -- Initialize all the direct-access attributes of this task. + + P := All_Attributes; + while P /= null loop + if P.Index /= 0 then + T.Direct_Attributes (P.Index) := + System.Storage_Elements.To_Address (P.Initial_Value); + end if; + + P := P.Next; + end loop; + + Unlock (All_Attrs_L'Access); + + exception + when others => null; + pragma Assert (False); + end Initialize_Attributes; + +end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads new file mode 100644 index 00000000000..84463e477f3 --- /dev/null +++ b/gcc/ada/s-tataat.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- Copyright (C) 1995-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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for the body of Ada.Task_Attributes. + +with Ada.Finalization; +-- used for Limited_Controlled + +with System.Storage_Elements; +-- used for Integer_Address + +package System.Tasking.Task_Attributes is + + type Attribute is new Integer; + -- A stand-in for the generic formal type of Ada.Task_Attributes + -- in the following declarations. + + type Node; + type Access_Node is access all Node; + type Dummy_Wrapper; + type Access_Dummy_Wrapper is access all Dummy_Wrapper; + + type Deallocator is access procedure (P : in out Access_Node); + -- Called to deallocate an Wrapper. P is a pointer to a Node within. + + type Instance; + + type Access_Instance is access all Instance; + + type Instance is new Ada.Finalization.Limited_Controlled with record + Deallocate : Deallocator; + Initial_Value : aliased System.Storage_Elements.Integer_Address; + + Index : Direct_Index; + -- The index of the TCB location used by this instantiation, + -- if it is stored in the TCB, otherwise zero. + + Next : Access_Instance; + -- Next instance in All_Attributes list. + end record; + + procedure Finalize (X : in out Instance); + + type Node is record + Wrapper : Access_Dummy_Wrapper; + Instance : Access_Instance; + Next : Access_Node; + end record; + + -- The following type is a stand-in for the actual + -- wrapper type, which is different for each instantiation + -- of Ada.Task_Attributes. + + type Dummy_Wrapper is record + Noed : aliased Node; + + Value : aliased Attribute; + -- The generic formal type, may be controlled + end record; + + In_Use : Direct_Index_Vector := 0; + -- is True for direct indices that are already used. + + All_Attributes : Access_Instance; + -- A linked list of all indirectly access attributes, + -- which includes all those that require finalization. + + All_Attrs_L : aliased System.Task_Primitives.RTS_Lock; + -- Protects In_Use, Next_Indirect_Index, and All_Attributes. + -- Deadlock prevention order of locking: + -- 1) All_Attrs_L + -- 2) All_Tasks_L + -- 3) any TCB.L + + procedure Initialize_Attributes (T : Task_ID); + -- Initialize all attributes created via Ada.Task_Attributes for T. + -- This must be called by the creator of the task, inside Create_Task, + -- via soft-link Initialize_Attributes_Link. On entry, abortion must + -- be deferred and the caller must hold no locks + + procedure Finalize_Attributes (T : Task_ID); + -- Finalize all attributes created via Ada.Task_Attributes for T. + -- This is to be called by the task after it is marked as terminated + -- (and before it actually dies), inside Vulnerable_Free_Task, via the + -- soft-link Finalize_Attributes_Link. On entry, abortion must be deferred + -- and T.L must be write-locked. + +end System.Tasking.Task_Attributes; diff --git a/gcc/ada/s-tpinop.adb b/gcc/ada/s-tpinop.adb new file mode 100644 index 00000000000..80524e4d038 --- /dev/null +++ b/gcc/ada/s-tpinop.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . -- +-- I N T E R R U P T _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- Copyright (C) 1998-2001 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.Task_Primitives.Interrupt_Operations is + + -- ??? The VxWorks version of System.Interrupt_Management needs to access + -- this array, but due to elaboration problems, it can't with this + -- package directly, so we export this variable for now. + + Interrupt_ID_Map : array (IM.Interrupt_ID) of ST.Task_ID; + pragma Export (Ada, Interrupt_ID_Map, + "system__task_primitives__interrupt_operations__interrupt_id_map"); + + ---------------------- + -- Get_Interrupt_ID -- + ---------------------- + + function Get_Interrupt_ID (T : ST.Task_ID) return IM.Interrupt_ID is + use type ST.Task_ID; + + begin + for Interrupt in IM.Interrupt_ID loop + if Interrupt_ID_Map (Interrupt) = T then + return Interrupt; + end if; + end loop; + + raise Program_Error; + end Get_Interrupt_ID; + + ----------------- + -- Get_Task_ID -- + ----------------- + + function Get_Task_ID (Interrupt : IM.Interrupt_ID) return ST.Task_ID is + begin + return Interrupt_ID_Map (Interrupt); + end Get_Task_ID; + + ---------------------- + -- Set_Interrupt_ID -- + ---------------------- + + procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_ID) is + begin + Interrupt_ID_Map (Interrupt) := T; + end Set_Interrupt_ID; + +end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/s-tpinop.ads b/gcc/ada/s-tpinop.ads new file mode 100644 index 00000000000..ccb308d777d --- /dev/null +++ b/gcc/ada/s-tpinop.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ P R I M I T I V E S . -- +-- I N T E R R U P T _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Interrupt_Management; +with System.Tasking; +package System.Task_Primitives.Interrupt_Operations is + + package IM renames System.Interrupt_Management; + package ST renames System.Tasking; + + procedure Set_Interrupt_ID (Interrupt : IM.Interrupt_ID; T : ST.Task_ID); + -- Associate an Interrupt_ID with a task. + + function Get_Interrupt_ID (T : ST.Task_ID) return IM.Interrupt_ID; + -- Return the Interrupt_ID associated with a task. + + function Get_Task_ID (Interrupt : IM.Interrupt_ID) return ST.Task_ID; + -- Return the Task_ID associated with an Interrupt. + +end System.Task_Primitives.Interrupt_Operations; diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb new file mode 100644 index 00000000000..fa37450cef8 --- /dev/null +++ b/gcc/ada/s-tpoben.adb @@ -0,0 +1,248 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- E N T R I E S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.11 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all the simple primitives related to +-- Protected_Objects with entries (i.e init, lock, unlock). + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the complex routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Operations. +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. + +with Ada.Exceptions; +-- used for Exception_Occurrence_Access + +with System.Task_Primitives.Operations; +-- used for Initialize_Lock +-- Write_Lock +-- Unlock +-- Get_Priority +-- Wakeup + +with System.Tasking.Initialization; +-- used for Defer_Abort, +-- Undefer_Abort, +-- Change_Base_Priority + +pragma Elaborate_All (System.Tasking.Initialization); +-- this insures that tasking is initialized if any protected objects are +-- created. + +package body System.Tasking.Protected_Objects.Entries is + + package STPO renames System.Task_Primitives.Operations; + + use Ada.Exceptions; + use STPO; + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Protection_Entries) is + Entry_Call : Entry_Call_Link; + Caller : Task_ID; + Ceiling_Violation : Boolean; + Self_ID : constant Task_ID := STPO.Self; + Old_Base_Priority : System.Any_Priority; + + begin + if Object.Finalized then + return; + end if; + + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); + + if Ceiling_Violation then + + -- Dip our own priority down to ceiling of lock. + -- See similar code in Tasking.Entry_Calls.Lock_Server. + + STPO.Write_Lock (Self_ID); + Old_Base_Priority := Self_ID.Common.Base_Priority; + Self_ID.New_Base_Priority := Object.Ceiling; + Initialization.Change_Base_Priority (Self_ID); + STPO.Unlock (Self_ID); + STPO.Write_Lock (Object.L'Unrestricted_Access, Ceiling_Violation); + + if Ceiling_Violation then + Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + end if; + + Object.Old_Base_Priority := Old_Base_Priority; + Object.Pending_Action := True; + end if; + + -- Send program_error to all tasks still queued on this object. + + for E in Object.Entry_Queues'Range loop + Entry_Call := Object.Entry_Queues (E).Head; + + while Entry_Call /= null loop + Caller := Entry_Call.Self; + Entry_Call.Exception_To_Raise := Program_Error'Identity; + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + exit when Entry_Call = Object.Entry_Queues (E).Tail; + Entry_Call := Entry_Call.Next; + end loop; + end loop; + + Object.Finalized := True; + STPO.Unlock (Object.L'Unrestricted_Access); + STPO.Finalize_Lock (Object.L'Unrestricted_Access); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : Protection_Entries_Access) + return Boolean + is + begin + return False; + end Has_Interrupt_Or_Attach_Handler; + + ----------------------------------- + -- Initialize_Protection_Entries -- + ----------------------------------- + + procedure Initialize_Protection_Entries + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access) + is + Init_Priority : Integer := Ceiling_Priority; + Self_ID : constant Task_ID := STPO.Self; + + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + if Locking_Policy = 'C' + and then Has_Interrupt_Or_Attach_Handler (Object) + and then Init_Priority not in System.Interrupt_Priority + then + -- Required by C.3.1(11) + + raise Program_Error; + end if; + + Initialization.Defer_Abort (Self_ID); + Initialize_Lock (Init_Priority, Object.L'Access); + Initialization.Undefer_Abort (Self_ID); + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.Compiler_Info := Compiler_Info; + Object.Pending_Action := False; + Object.Call_In_Progress := null; + Object.Entry_Bodies := Entry_Bodies; + Object.Find_Body_Index := Find_Body_Index; + + for E in Object.Entry_Queues'Range loop + Object.Entry_Queues (E).Head := null; + Object.Entry_Queues (E).Tail := null; + end loop; + end Initialize_Protection_Entries; + + ------------------ + -- Lock_Entries -- + ------------------ + + procedure Lock_Entries + (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean) is + begin + -- The lock is made without defering abortion. + + -- Therefore the abortion has to be deferred before calling this + -- routine. This means that the compiler has to generate a Defer_Abort + -- call before the call to Lock. + + -- The caller is responsible for undeferring abortion, and compiler + -- generated calls must be protected with cleanup handlers to ensure + -- that abortion is undeferred in all cases. + + pragma Assert (STPO.Self.Deferral_Level > 0); + Write_Lock (Object.L'Access, Ceiling_Violation); + end Lock_Entries; + + procedure Lock_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + begin + pragma Assert (STPO.Self.Deferral_Level > 0); + Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + end if; + end Lock_Entries; + + ---------------------------- + -- Lock_Read_Only_Entries -- + ---------------------------- + + procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access) is + Ceiling_Violation : Boolean; + begin + Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + Raise_Exception (Program_Error'Identity, "Ceiling Violation"); + end if; + end Lock_Read_Only_Entries; + + -------------------- + -- Unlock_Entries -- + -------------------- + + procedure Unlock_Entries (Object : Protection_Entries_Access) is + begin + Unlock (Object.L'Access); + end Unlock_Entries; + +end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads new file mode 100644 index 00000000000..58b600d69a2 --- /dev/null +++ b/gcc/ada/s-tpoben.ads @@ -0,0 +1,189 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- E N T R I E S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- Copyright (C) 1992-2001, 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 contains all the simple primitives related to +-- Protected_Objects with entries (i.e init, lock, unlock). +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the complex routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Operations. +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Finalization; +-- used for Limited_Controlled + +with Unchecked_Conversion; + +package System.Tasking.Protected_Objects.Entries is + pragma Elaborate_Body; + + subtype Positive_Protected_Entry_Index is + Protected_Entry_Index range 1 .. Protected_Entry_Index'Last; + + type Find_Body_Index_Access is access + function + (O : System.Address; + E : Protected_Entry_Index) + return Protected_Entry_Index; + + type Protected_Entry_Body_Array is + array (Positive_Protected_Entry_Index range <>) of Entry_Body; + -- This is an array of the executable code for all entry bodies of + -- a protected type. + + type Protected_Entry_Body_Access is access all Protected_Entry_Body_Array; + + type Protected_Entry_Queue_Array is + array (Protected_Entry_Index range <>) of Entry_Queue; + + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + -- note that there is a simplified version of this type declared in + -- System.Tasking.PO_Simple that handle the simple case (no entries). + + type Protection_Entries (Num_Entries : Protected_Entry_Index) is new + Ada.Finalization.Limited_Controlled + with record + L : aliased Task_Primitives.Lock; + -- The underlying lock associated with a Protection_Entries. + -- Note that you should never (un)lock Object.L directly, but instead + -- use Lock_Entries/Unlock_Entries. + + Compiler_Info : System.Address; + Call_In_Progress : Entry_Call_Link; + Ceiling : System.Any_Priority; + Old_Base_Priority : System.Any_Priority; + Pending_Action : Boolean; + -- Flag indicating that priority has been dipped temporarily + -- in order to avoid violating the priority ceiling of the lock + -- associated with this protected object, in Lock_Server. + -- The flag tells Unlock_Server or Unlock_And_Update_Server to + -- restore the old priority to Old_Base_Priority. This is needed + -- because of situations (bad language design?) where one + -- needs to lock a PO but to do so would violate the priority + -- ceiling. For example, this can happen when an entry call + -- has been requeued to a lower-priority object, and the caller + -- then tries to cancel the call while its own priority is higher + -- than the ceiling of the new PO. + Finalized : Boolean := False; + -- Set to True by Finalize to make this routine idempotent. + + Entry_Bodies : Protected_Entry_Body_Access; + + -- The following function maps the entry index in a call (which denotes + -- the queue to the proper entry) into the body of the entry. + + Find_Body_Index : Find_Body_Index_Access; + Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries); + end record; + pragma Volatile (Protection_Entries); + + -- No default initial values for this type, since call records + -- will need to be re-initialized before every use. + + type Protection_Entries_Access is access all Protection_Entries'Class; + -- See comments in s-tassta.adb about the implicit call to Current_Master + -- generated by this declaration. + + function To_Protection_Entries is new Unchecked_Conversion + (Protection_Access, Protection_Entries_Access); + + function To_Address is + new Unchecked_Conversion (Protection_Entries_Access, System.Address); + function To_Protection is + new Unchecked_Conversion (System.Address, Protection_Entries_Access); + + function Has_Interrupt_Or_Attach_Handler + (Object : Protection_Entries_Access) return Boolean; + -- Returns True if an Interrupt_Handler or Attach_Handler pragma applies + -- to the protected object. That is to say this primitive returns False for + -- Protection, but is overriden to return True when interrupt handlers are + -- declared so the check required by C.3.1(11) can be implemented in + -- System.Tasking.Protected_Objects.Initialize_Protection. + + procedure Initialize_Protection_Entries + (Object : Protection_Entries_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Bodies : Protected_Entry_Body_Access; + Find_Body_Index : Find_Body_Index_Access); + -- Initialize the Object parameter so that it can be used by the runtime + -- to keep track of the runtime state of a protected object. + + procedure Lock_Entries (Object : Protection_Entries_Access); + -- Lock a protected object for write access. Upon return, the caller + -- owns the lock to this object, and no other call to Lock or + -- Lock_Read_Only with the same argument will return until the + -- corresponding call to Unlock has been made by the caller. + -- Program_Error is raised in case of ceiling violation. + + procedure Lock_Entries + (Object : Protection_Entries_Access; Ceiling_Violation : out Boolean); + -- Same as above, but return the ceiling violation status instead of + -- raising Program_Error. + + procedure Lock_Read_Only_Entries (Object : Protection_Entries_Access); + -- Lock a protected object for read access. Upon return, the caller + -- owns the lock for read access, and no other calls to Lock with the + -- same argument will return until the corresponding call to Unlock + -- has been made by the caller. Other calls to Lock_Read_Only may (but + -- need not) return before the call to Unlock, and the corresponding + -- callers will also own the lock for read access. + -- + -- Note: we are not currently using this interface, it is provided + -- for possible future use. At the current time, everyone uses Lock + -- for both read and write locks. + + procedure Unlock_Entries (Object : Protection_Entries_Access); + -- Relinquish ownership of the lock for the object represented by + -- the Object parameter. If this ownership was for write access, or + -- if it was for read access where there are no other read access + -- locks outstanding, one (or more, in the case of Lock_Read_Only) + -- of the tasks waiting on this lock (if any) will be given the + -- lock and allowed to return from the Lock or Lock_Read_Only call. + +private + + procedure Finalize (Object : in out Protection_Entries); + -- Clean up a Protection object; in particular, finalize the associated + -- Lock object. + +end System.Tasking.Protected_Objects.Entries; diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb new file mode 100644 index 00000000000..2e865821bc9 --- /dev/null +++ b/gcc/ada/s-tpobop.adb @@ -0,0 +1,981 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains all the extended primitives related to +-- Protected_Objects with entries. + +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. + +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- This package contains all primitives related to Protected_Objects. +-- Note: the compiler generates direct calls to this interface, via Rtsfind. + +with Ada.Exceptions; +-- Used for Exception_ID +-- Null_Id +-- Raise_Exception + +with System.Task_Primitives.Operations; +-- used for Initialize_Lock +-- Write_Lock +-- Unlock +-- Get_Priority +-- Wakeup + +with System.Tasking.Entry_Calls; +-- used for Wait_For_Completion +-- Wait_Until_Abortable + +with System.Tasking.Initialization; +-- Used for Defer_Abort, +-- Undefer_Abort, +-- Change_Base_Priority + +pragma Elaborate_All (System.Tasking.Initialization); +-- This insures that tasking is initialized if any protected objects are +-- created. + +with System.Tasking.Queuing; +-- used for Enqueue +-- Broadcast_Program_Error +-- Select_Protected_Entry_Call +-- Onqueue +-- Count_Waiting + +with System.Tasking.Rendezvous; +-- used for Task_Do_Or_Queue + +with System.Tasking.Debug; +-- used for Trace + +package body System.Tasking.Protected_Objects.Operations is + + package STPO renames System.Task_Primitives.Operations; + + use Task_Primitives; + use Tasking; + use Ada.Exceptions; + use Entries; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean); + pragma Inline (Update_For_Queue_To_PO); + -- Update the state of an existing entry call to reflect + -- the fact that it is being enqueued, based on + -- whether the current queuing action is with or without abort. + -- Call this only while holding the PO's lock. + -- It returns with the PO's lock still held. + + --------------------------------- + -- Cancel_Protected_Entry_Call -- + --------------------------------- + + -- Compiler interface only. Do not call from within the RTS. + -- This should have analogous effect to Cancel_Task_Entry_Call, + -- setting the value of Block.Cancelled instead of returning + -- the parameter value Cancelled. + + -- The effect should be idempotent, since the call may already + -- have been dequeued. + + -- source code: + + -- select r.e; + -- ...A... + -- then abort + -- ...B... + -- end select; + + -- expanded code: + + -- declare + -- X : protected_entry_index := 1; + -- B80b : communication_block; + -- _init_proc (B80b); + -- begin + -- begin + -- A79b : label + -- A79b : declare + -- procedure _clean is + -- begin + -- if enqueued (B80b) then + -- cancel_protected_entry_call (B80b); + -- end if; + -- return; + -- end _clean; + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, asynchronous_call, B80b, objectF => 0); + -- if enqueued (B80b) then + -- ...B... + -- end if; + -- at end + -- _clean; + -- end A79b; + -- exception + -- when _abort_signal => + -- abort_undefer.all; + -- null; + -- end; + -- if not cancelled (B80b) then + -- x := ...A... + -- end if; + -- end; + + -- If the entry call completes after we get into the abortable part, + -- Abort_Signal should be raised and ATC will take us to the at-end + -- handler, which will call _clean. + + -- If the entry call returns with the call already completed, + -- we can skip this, and use the "if enqueued()" to go past + -- the at-end handler, but we will still call _clean. + + -- If the abortable part completes before the entry call is Done, + -- it will call _clean. + + -- If the entry call or the abortable part raises an exception, + -- we will still call _clean, but the value of Cancelled should not matter. + + -- Whoever calls _clean first gets to decide whether the call + -- has been "cancelled". + + -- Enqueued should be true if there is any chance that the call + -- is still on a queue. It seems to be safe to make it True if + -- the call was Onqueue at some point before return from + -- Protected_Entry_Call. + + -- Cancelled should be true iff the abortable part completed + -- and succeeded in cancelling the entry call before it completed. + + -- ????? + -- The need for Enqueued is less obvious. + -- The "if enqueued()" tests are not necessary, since both + -- Cancel_Protected_Entry_Call and Protected_Entry_Call must + -- do the same test internally, with locking. The one that + -- makes cancellation conditional may be a useful heuristic + -- since at least 1/2 the time the call should be off-queue + -- by that point. The other one seems totally useless, since + -- Protected_Entry_Call must do the same check and then + -- possibly wait for the call to be abortable, internally. + + -- We can check Call.State here without locking the caller's mutex, + -- since the call must be over after returning from Wait_For_Completion. + -- No other task can access the call record at this point. + + procedure Cancel_Protected_Entry_Call + (Block : in out Communication_Block) + is + begin + Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); + end Cancel_Protected_Entry_Call; + + --------------- + -- Cancelled -- + --------------- + + function Cancelled (Block : Communication_Block) return Boolean is + begin + return Block.Cancelled; + end Cancelled; + + ------------------------- + -- Complete_Entry_Body -- + ------------------------- + + procedure Complete_Entry_Body (Object : Protection_Entries_Access) is + begin + Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); + end Complete_Entry_Body; + + -------------- + -- Enqueued -- + -------------- + + function Enqueued (Block : Communication_Block) return Boolean is + begin + return Block.Enqueued; + end Enqueued; + + ------------------------------------- + -- Exceptional_Complete_Entry_Body -- + ------------------------------------- + + procedure Exceptional_Complete_Entry_Body + (Object : Protection_Entries_Access; + Ex : Ada.Exceptions.Exception_Id) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); + + -- We must have abort deferred, since we are inside + -- a protected operation. + + if Entry_Call /= null then + + -- The call was not requeued. + + Entry_Call.Exception_To_Raise := Ex; + +-- ????? +-- The caller should do the following, after return from this +-- procedure, if Call_In_Progress /= null +-- Write_Lock (Entry_Call.Self); +-- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done); +-- Unlock (Entry_Call.Self); + + end if; + end Exceptional_Complete_Entry_Body; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Self_ID : Task_ID; + Object : Protection_Entries_Access; + Entry_Call : Entry_Call_Link; + With_Abort : Boolean) + is + E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E); + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + Barrier_Value : Boolean; + + begin + -- When the Action procedure for an entry body returns, it is either + -- completed (having called [Exceptional_]Complete_Entry_Body) or it + -- is queued, having executed a requeue statement. + + Barrier_Value := + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, E)). + Barrier (Object.Compiler_Info, E); + + if Barrier_Value then + + -- Not abortable while service is in progress. + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + pragma Debug + (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, E)).Action ( + Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + + if Object.Call_In_Progress /= null then + + -- Body of current entry served call to completion + + Object.Call_In_Progress := null; + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + + else + -- Body of current entry requeued the call + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call was requeued to a task + + if not Rendezvous.Task_Do_Or_Queue + (Self_ID, Entry_Call, + With_Abort => Entry_Call.Requeue_With_Abort) + then + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end if; + return; + end if; + + if Object /= New_Object then + -- Requeue is on a different object + + Lock_Entries (New_Object, Ceiling_Violation); + + if Ceiling_Violation then + Object.Call_In_Progress := null; + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + + else + PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort); + PO_Service_Entries (Self_ID, New_Object); + Unlock_Entries (New_Object); + end if; + + else + -- Requeue is on same protected object + + if Entry_Call.Requeue_With_Abort + and then Entry_Call.Cancellation_Attempted + then + -- If this is a requeue with abort and someone tried + -- to cancel this call, cancel it at this point. + + Entry_Call.State := Cancelled; + return; + end if; + + if not With_Abort or else + Entry_Call.Mode /= Conditional_Call + then + E := Protected_Entry_Index (Entry_Call.E); + Queuing.Enqueue + (New_Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, With_Abort); + + else + -- ????? + -- Can we convert this recursion to a loop? + + PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, With_Abort); + end if; + end if; + end if; + + elsif Entry_Call.Mode /= Conditional_Call or else + not With_Abort then + Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, With_Abort); + + else + -- Conditional_Call and With_Abort + + STPO.Write_Lock (Entry_Call.Self); + pragma Assert (Entry_Call.State >= Was_Abortable); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + end if; + + exception + when others => + Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); + end PO_Do_Or_Queue; + + ------------------------ + -- PO_Service_Entries -- + ------------------------ + + procedure PO_Service_Entries + (Self_ID : Task_ID; + Object : Protection_Entries_Access) + is + Entry_Call : Entry_Call_Link; + E : Protected_Entry_Index; + Caller : Task_ID; + New_Object : Protection_Entries_Access; + Ceiling_Violation : Boolean; + + begin + loop + Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); + + if Entry_Call /= null then + E := Protected_Entry_Index (Entry_Call.E); + + -- Not abortable while service is in progress. + + if Entry_Call.State = Now_Abortable then + Entry_Call.State := Was_Abortable; + end if; + + Object.Call_In_Progress := Entry_Call; + + begin + pragma Debug + (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); + Object.Entry_Bodies ( + Object.Find_Body_Index (Object.Compiler_Info, E)).Action ( + Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); + exception + when others => + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end; + + if Object.Call_In_Progress /= null then + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + STPO.Write_Lock (Caller); + Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); + STPO.Unlock (Caller); + + else + -- Call needs to be requeued + + New_Object := To_Protection (Entry_Call.Called_PO); + + if New_Object = null then + + -- Call is to be requeued to a task entry + + if not Rendezvous.Task_Do_Or_Queue + (Self_ID, Entry_Call, + With_Abort => Entry_Call.Requeue_With_Abort) + then + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + end if; + + else + -- Call should be requeued to a PO + + if Object /= New_Object then + -- Requeue is to different PO + + Lock_Entries (New_Object, Ceiling_Violation); + + if Ceiling_Violation then + Object.Call_In_Progress := null; + Queuing.Broadcast_Program_Error + (Self_ID, Object, Entry_Call); + + else + PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, + Entry_Call.Requeue_With_Abort); + PO_Service_Entries (Self_ID, New_Object); + Unlock_Entries (New_Object); + end if; + + else + -- Requeue is to same protected object + + -- ??? Try to compensate apparent failure of the + -- scheduler on some OS (e.g VxWorks) to give higher + -- priority tasks a chance to run (see CXD6002). + + STPO.Yield (False); + + if Entry_Call.Requeue_With_Abort + and then Entry_Call.Cancellation_Attempted + then + -- If this is a requeue with abort and someone tried + -- to cancel this call, cancel it at this point. + + Entry_Call.State := Cancelled; + exit; + end if; + + if not Entry_Call.Requeue_With_Abort or else + Entry_Call.Mode /= Conditional_Call + then + E := Protected_Entry_Index (Entry_Call.E); + Queuing.Enqueue + (New_Object.Entry_Queues (E), Entry_Call); + Update_For_Queue_To_PO (Entry_Call, + Entry_Call.Requeue_With_Abort); + + else + PO_Do_Or_Queue (Self_ID, New_Object, Entry_Call, + Entry_Call.Requeue_With_Abort); + end if; + end if; + end if; + end if; + + else + exit; + end if; + end loop; + end PO_Service_Entries; + + --------------------- + -- Protected_Count -- + --------------------- + + function Protected_Count + (Object : Protection_Entries'Class; + E : Protected_Entry_Index) + return Natural + is + begin + return Queuing.Count_Waiting (Object.Entry_Queues (E)); + end Protected_Count; + + -------------------------- + -- Protected_Entry_Call -- + -------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + -- select r.e; + -- ...A... + -- else + -- ...B... + -- end select; + + -- declare + -- X : protected_entry_index := 1; + -- B85b : communication_block; + -- _init_proc (B85b); + -- begin + -- protected_entry_call (rTV!(r)._object'unchecked_access, X, + -- null_address, conditional_call, B85b, objectF => 0); + -- if cancelled (B85b) then + -- ...B... + -- else + -- ...A... + -- end if; + -- end; + + -- See also Cancel_Protected_Entry_Call for code expansion of + -- asynchronous entry call. + + -- The initial part of this procedure does not need to lock the + -- the calling task's ATCB, up to the point where the call record + -- first may be queued (PO_Do_Or_Queue), since before that no + -- other task will have access to the record. + + -- If this is a call made inside of an abort deferred region, + -- the call should be never abortable. + + -- If the call was not queued abortably, we need to wait + -- until it is before proceeding with the abortable part. + + -- There are some heuristics here, just to save time for + -- frequently occurring cases. For example, we check + -- Initially_Abortable to try to avoid calling the procedure + -- Wait_Until_Abortable, since the normal case for async. + -- entry calls is to be queued abortably. + + -- Another heuristic uses the Block.Enqueued to try to avoid + -- calling Cancel_Protected_Entry_Call if the call can be + -- served immediately. + + procedure Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block) + is + Self_ID : Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + Initially_Abortable : Boolean; + Ceiling_Violation : Boolean; + + begin + pragma Debug + (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); + + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + Raise_Exception (Storage_Error'Identity, + "not enough ATC nesting levels"); + end if; + + Initialization.Defer_Abort (Self_ID); + Lock_Entries (Object, Ceiling_Violation); + + if Ceiling_Violation then + + -- Failed ceiling check + + Initialization.Undefer_Abort (Self_ID); + raise Program_Error; + end if; + + Block.Self := Self_ID; + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_ID, "PEC: entered ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Entry_Call := + Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Mode; + Entry_Call.Cancellation_Attempted := False; + + if Self_ID.Deferral_Level > 1 then + Entry_Call.State := Never_Abortable; + else + Entry_Call.State := Now_Abortable; + end if; + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_ID); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True); + Initially_Abortable := Entry_Call.State = Now_Abortable; + PO_Service_Entries (Self_ID, Object); + + Unlock_Entries (Object); + + -- Try to prevent waiting later (in Cancel_Protected_Entry_Call) + -- for completed or cancelled calls. (This is a heuristic, only.) + + if Entry_Call.State >= Done then + + -- Once State >= Done it will not change any more. + + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + pragma Debug + (Debug.Trace (Self_ID, "PEC: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Block.Enqueued := False; + Block.Cancelled := Entry_Call.State = Cancelled; + Initialization.Undefer_Abort (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + return; + + else + -- In this case we cannot conclude anything, + -- since State can change concurrently. + null; + end if; + + -- Now for the general case. + + if Mode = Asynchronous_Call then + + -- Try to avoid an expensive call. + + if not Initially_Abortable then + Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); + end if; + + elsif Mode < Asynchronous_Call then + + -- Simple_Call or Conditional_Call + + STPO.Write_Lock (Self_ID); + Entry_Calls.Wait_For_Completion (Self_ID, Entry_Call); + STPO.Unlock (Self_ID); + Block.Cancelled := Entry_Call.State = Cancelled; + + else + pragma Assert (False); + null; + end if; + + Initialization.Undefer_Abort (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + + end Protected_Entry_Call; + + ---------------------------- + -- Protected_Entry_Caller -- + ---------------------------- + + function Protected_Entry_Caller (Object : Protection_Entries'Class) + return Task_ID is + begin + return Object.Call_In_Progress.Self; + end Protected_Entry_Caller; + + ----------------------------- + -- Requeue_Protected_Entry -- + ----------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + -- entry e when b is + -- begin + -- b := false; + -- ...A... + -- requeue e2; + -- end e; + + -- procedure rPT__E10b (O : address; P : address; E : + -- protected_entry_index) is + -- type rTVP is access rTV; + -- freeze rTVP [] + -- _object : rTVP := rTVP!(O); + -- begin + -- declare + -- rR : protection renames _object._object; + -- vP : integer renames _object.v; + -- bP : boolean renames _object.b; + -- begin + -- b := false; + -- ...A... + -- requeue_protected_entry (rR'unchecked_access, rR' + -- unchecked_access, 2, false, objectF => 0, new_objectF => + -- 0); + -- return; + -- end; + -- complete_entry_body (_object._object'unchecked_access, objectF => + -- 0); + -- return; + -- exception + -- when others => + -- abort_undefer.all; + -- exceptional_complete_entry_body (_object._object' + -- unchecked_access, current_exception, objectF => 0); + -- return; + -- end rPT__E10b; + + procedure Requeue_Protected_Entry + (Object : Protection_Entries_Access; + New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; + + begin + pragma Debug + (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P')); + pragma Assert (STPO.Self.Deferral_Level > 0); + + Entry_Call.E := Entry_Index (E); + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + Entry_Call.Requeue_With_Abort := With_Abort; + Object.Call_In_Progress := null; + end Requeue_Protected_Entry; + + ------------------------------------- + -- Requeue_Task_To_Protected_Entry -- + ------------------------------------- + + -- Compiler interface only. + + -- accept e1 do + -- ...A... + -- requeue r.e2; + -- end e1; + + -- A79b : address; + -- L78b : label + -- begin + -- accept_call (1, A79b); + -- ...A... + -- requeue_task_to_protected_entry (rTV!(r)._object' + -- unchecked_access, 2, false, new_objectF => 0); + -- goto L78b; + -- <<L78b>> + -- complete_rendezvous; + -- exception + -- when all others => + -- exceptional_complete_rendezvous (get_gnat_exception); + -- end; + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean) + is + Self_ID : constant Task_ID := STPO.Self; + Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; + + begin + Initialization.Defer_Abort (Self_ID); + STPO.Write_Lock (Self_ID); + Entry_Call.Needs_Requeue := True; + Entry_Call.Requeue_With_Abort := With_Abort; + Entry_Call.Called_PO := To_Address (New_Object); + Entry_Call.Called_Task := null; + STPO.Unlock (Self_ID); + Entry_Call.E := Entry_Index (E); + Initialization.Undefer_Abort (Self_ID); + end Requeue_Task_To_Protected_Entry; + + -- ?????? + -- Do we really need to lock Self_ID above? + -- Might the caller be trying to cancel? + -- If so, it should fail, since the call state should not be + -- abortable while the call is in service. + + --------------------- + -- Service_Entries -- + --------------------- + + procedure Service_Entries (Object : Protection_Entries_Access) is + Self_ID : constant Task_ID := STPO.Self; + begin + PO_Service_Entries (Self_ID, Object); + end Service_Entries; + + -------------------------------- + -- Timed_Protected_Entry_Call -- + -------------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + procedure Timed_Protected_Entry_Call + (Object : Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean) + is + Self_ID : Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + Ceiling_Violation : Boolean; + + begin + if Self_ID.ATC_Nesting_Level = ATC_Level'Last then + Raise_Exception (Storage_Error'Identity, + "not enough ATC nesting levels"); + end if; + + Initialization.Defer_Abort (Self_ID); + Lock_Entries (Object, Ceiling_Violation); + + if Ceiling_Violation then + Initialization.Undefer_Abort (Self_ID); + raise Program_Error; + end if; + + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; + pragma Debug + (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Entry_Call := + Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; + Entry_Call.Next := null; + Entry_Call.Mode := Timed_Call; + Entry_Call.Cancellation_Attempted := False; + + if Self_ID.Deferral_Level > 1 then + Entry_Call.State := Never_Abortable; + else + Entry_Call.State := Now_Abortable; + end if; + + Entry_Call.E := Entry_Index (E); + Entry_Call.Prio := STPO.Get_Priority (Self_ID); + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Called_PO := To_Address (Object); + Entry_Call.Called_Task := null; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True); + PO_Service_Entries (Self_ID, Object); + + Unlock_Entries (Object); + + -- Try to avoid waiting for completed or cancelled calls. + + if Entry_Call.State >= Done then + Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; + pragma Debug + (Debug.Trace (Self_ID, "TPEC: exited to ATC level: " & + ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); + Entry_Call_Successful := Entry_Call.State = Done; + Initialization.Undefer_Abort (Self_ID); + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + return; + end if; + + Entry_Calls.Wait_For_Completion_With_Timeout + (Self_ID, Entry_Call, Timeout, Mode); + Initialization.Undefer_Abort (Self_ID); + Entry_Call_Successful := Entry_Call.State = Done; + Entry_Calls.Check_Exception (Self_ID, Entry_Call); + end Timed_Protected_Entry_Call; + + ---------------------------- + -- Update_For_Queue_To_PO -- + ---------------------------- + + -- Update the state of an existing entry call, based on + -- whether the current queuing action is with or without abort. + -- Call this only while holding the server's lock. + -- It returns with the server's lock released. + + New_State : constant array (Boolean, Entry_Call_State) + of Entry_Call_State := + (True => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Now_Abortable, + Was_Abortable => Now_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled), + False => + (Never_Abortable => Never_Abortable, + Not_Yet_Abortable => Not_Yet_Abortable, + Was_Abortable => Was_Abortable, + Now_Abortable => Now_Abortable, + Done => Done, + Cancelled => Cancelled) + ); + + procedure Update_For_Queue_To_PO + (Entry_Call : Entry_Call_Link; + With_Abort : Boolean) + is + Old : Entry_Call_State := Entry_Call.State; + + begin + pragma Assert (Old < Done); + + Entry_Call.State := New_State (With_Abort, Entry_Call.State); + + if Entry_Call.Mode = Asynchronous_Call then + if Old < Was_Abortable and then + Entry_Call.State = Now_Abortable + then + STPO.Write_Lock (Entry_Call.Self); + + if Entry_Call.Self.Common.State = Async_Select_Sleep then + STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); + end if; + + STPO.Unlock (Entry_Call.Self); + end if; + + elsif Entry_Call.Mode = Conditional_Call then + pragma Assert (Entry_Call.State < Was_Abortable); + null; + end if; + end Update_For_Queue_To_PO; + +end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/s-tpobop.ads b/gcc/ada/s-tpobop.ads new file mode 100644 index 00000000000..6ffeeea75c6 --- /dev/null +++ b/gcc/ada/s-tpobop.ads @@ -0,0 +1,207 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1992-2001, 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 contains all the extended primitives related to +-- Protected_Objects with entries. +-- The handling of protected objects with no entries is done in +-- System.Tasking.Protected_Objects, the simple routines for protected +-- objects with entries in System.Tasking.Protected_Objects.Entries. +-- The split between Entries and Operations is needed to break circular +-- dependencies inside the run time. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +with Ada.Exceptions; +-- used for Exception_Id + +with System.Tasking.Protected_Objects.Entries; + +package System.Tasking.Protected_Objects.Operations is + pragma Elaborate_Body; + + type Communication_Block is private; + -- Objects of this type are passed between GNARL calls to allow RTS + -- information to be preserved. + + procedure Protected_Entry_Call + (Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Mode : Call_Modes; + Block : out Communication_Block); + -- Make a protected entry call to the specified object. + -- Pend a protected entry call on the protected object represented + -- by Object. A pended call is not queued; it may be executed immediately + -- or queued, depending on the state of the entry barrier. + -- + -- E + -- The index representing the entry to be called. + -- + -- Uninterpreted_Data + -- This will be returned by Next_Entry_Call when this call is serviced. + -- It can be used by the compiler to pass information between the + -- caller and the server, in particular entry parameters. + -- + -- Mode + -- The kind of call to be pended + -- + -- Block + -- Information passed between runtime calls by the compiler + + procedure Timed_Protected_Entry_Call + (Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean); + -- Same as the Protected_Entry_Call but with time-out specified. + -- This routines is used when we do not use ATC mechanism to implement + -- timed entry calls. + + procedure Service_Entries (Object : Entries.Protection_Entries_Access); + pragma Inline (Service_Entries); + + procedure PO_Service_Entries + (Self_ID : Task_ID; + Object : Entries.Protection_Entries_Access); + -- Service all entry queues of the specified object, executing the + -- corresponding bodies of any queued entry calls that are waiting + -- on True barriers. This is used when the state of a protected + -- object may have changed, in particular after the execution of + -- the statement sequence of a protected procedure. + -- Note that servicing an entry may change the value of one or more + -- barriers, so this routine keeps checking barriers until all of + -- them are closed. + -- + -- This must be called with abortion deferred and with the corresponding + -- object locked. + + procedure Complete_Entry_Body (Object : Entries.Protection_Entries_Access); + -- Called from within an entry body procedure, indicates that the + -- corresponding entry call has been serviced. + + procedure Exceptional_Complete_Entry_Body + (Object : Entries.Protection_Entries_Access; + Ex : Ada.Exceptions.Exception_Id); + -- Perform all of the functions of Complete_Entry_Body. In addition, + -- report in Ex the exception whose propagation terminated the entry + -- body to the runtime system. + + procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block); + -- Attempt to cancel the most recent protected entry call. If the call is + -- not queued abortably, wait until it is or until it has completed. + -- If the call is actually cancelled, the called object will be + -- locked on return from this call. Get_Cancelled (Block) can be + -- used to determine if the cancellation took place; there + -- may be entries needing service in this case. + -- + -- Block passes information between this and other runtime calls. + + function Enqueued (Block : Communication_Block) return Boolean; + -- Returns True if the Protected_Entry_Call which returned the + -- specified Block object was queued; False otherwise. + + function Cancelled (Block : Communication_Block) return Boolean; + -- Returns True if the Protected_Entry_Call which returned the + -- specified Block object was cancelled, False otherwise. + + procedure Requeue_Protected_Entry + (Object : Entries.Protection_Entries_Access; + New_Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean); + -- If Object = New_Object, queue the protected entry call on Object + -- currently being serviced on the queue corresponding to the entry + -- represented by E. + -- + -- If Object /= New_Object, transfer the call to New_Object.E, + -- executing or queuing it as appropriate. + -- + -- With_Abort---True if the call is to be queued abortably, false + -- otherwise. + + procedure Requeue_Task_To_Protected_Entry + (New_Object : Entries.Protection_Entries_Access; + E : Protected_Entry_Index; + With_Abort : Boolean); + -- Transfer task entry call currently being serviced to entry E + -- on New_Object. + -- + -- With_Abort---True if the call is to be queued abortably, false + -- otherwise. + + function Protected_Count + (Object : Entries.Protection_Entries'Class; + E : Protected_Entry_Index) + return Natural; + -- Return the number of entry calls to E on Object. + + function Protected_Entry_Caller + (Object : Entries.Protection_Entries'Class) return Task_ID; + -- Return value of E'Caller, where E is the protected entry currently + -- being handled. This will only work if called from within an entry + -- body, as required by the LRM (C.7.1(14)). + + -- For internal use only: + + procedure PO_Do_Or_Queue + (Self_ID : Task_ID; + Object : Entries.Protection_Entries_Access; + Entry_Call : Entry_Call_Link; + With_Abort : Boolean); + -- This procedure either executes or queues an entry call, depending + -- on the status of the corresponding barrier. It assumes that abortion + -- is deferred and that the specified object is locked. + +private + type Communication_Block is record + Self : Task_ID; + Enqueued : Boolean := True; + Cancelled : Boolean := False; + end record; + pragma Volatile (Communication_Block); + + -- ????? + -- The Communication_Block seems to be a relic. + -- At the moment, the compiler seems to be generating + -- unnecessary conditional code based on this block. + -- See the code generated for async. select with task entry + -- call for another way of solving this. + +end System.Tasking.Protected_Objects.Operations; diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb new file mode 100644 index 00000000000..dcecc3163d9 --- /dev/null +++ b/gcc/ada/s-tposen.adb @@ -0,0 +1,599 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- S I N G L E _ E N T R Y -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1998-2001 Ada Core Technologies -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off subprogram ordering check, since restricted GNARLI +-- subprograms are gathered together at end. + +-- This package provides an optimized version of Protected_Objects.Operations +-- and Protected_Objects.Entries making the following assumptions: +-- +-- PO have only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- No Requeue +-- None of the tasks will terminate (no need for finalization) +-- +-- This interface is intended to be used in the ravenscar and restricted +-- profiles, the compiler is responsible for ensuring that the conditions +-- mentioned above are respected, except for the No_Entry_Queue restriction +-- that is checked dynamically in this package, since the check cannot be +-- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, +-- PO_Service_Entry). + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during tasking +-- operations. It can cause infinite loops and other problems. + +pragma Suppress (All_Checks); + +with System.Task_Primitives.Operations; +-- used for Self +-- Finalize_Lock +-- Write_Lock +-- Unlock + +with Ada.Exceptions; +-- used for Exception_Id; + +with Unchecked_Conversion; + +package body System.Tasking.Protected_Objects.Single_Entry is + + package STPO renames System.Task_Primitives.Operations; + + function To_Address is new + Unchecked_Conversion (Protection_Entry_Access, System.Address); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Send_Program_Error + (Self_Id : Task_ID; + Entry_Call : Entry_Call_Link); + pragma Inline (Send_Program_Error); + -- Raise Program_Error in the caller of the specified entry call + + -------------------------- + -- Entry Calls Handling -- + -------------------------- + + procedure Wakeup_Entry_Caller + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State); + pragma Inline (Wakeup_Entry_Caller); + -- This is called at the end of service of an entry call, + -- to abort the caller if he is in an abortable part, and + -- to wake up the caller if he is on Entry_Caller_Sleep. + -- Call it holding the lock of Entry_Call.Self. + -- + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + procedure Wait_For_Completion + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + pragma Inline (Wait_For_Completion); + -- This procedure suspends the calling task until the specified entry call + -- has either been completed or cancelled. On exit, the call will not be + -- queued. This waits for calls on protected entries. + -- Call this only when holding Self_ID locked. + + procedure Wait_For_Completion_With_Timeout + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes); + -- Same as Wait_For_Completion but it waits for a timeout with the value + -- specified in Wakeup_Time as well. + -- Self_ID will be locked by this procedure. + + procedure Check_Exception + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link); + pragma Inline (Check_Exception); + -- Raise any pending exception from the Entry_Call. + -- This should be called at the end of every compiler interface procedure + -- that implements an entry call. + -- The caller should not be holding any locks, or there will be deadlock. + + procedure PO_Do_Or_Queue + (Self_Id : Task_ID; + Object : Protection_Entry_Access; + Entry_Call : Entry_Call_Link); + + --------------------- + -- Check_Exception -- + --------------------- + + procedure Check_Exception + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + use type Ada.Exceptions.Exception_Id; + + procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); + pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); + + E : constant Ada.Exceptions.Exception_Id := + Entry_Call.Exception_To_Raise; + + begin + if E /= Ada.Exceptions.Null_Id then + Internal_Raise (E); + end if; + end Check_Exception; + + ------------------------ + -- Send_Program_Error -- + ------------------------ + + procedure Send_Program_Error + (Self_Id : Task_ID; + Entry_Call : Entry_Call_Link) + is + Caller : constant Task_ID := Entry_Call.Self; + begin + Entry_Call.Exception_To_Raise := Program_Error'Identity; + STPO.Write_Lock (Caller); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + end Send_Program_Error; + + ------------------------- + -- Wait_For_Completion -- + ------------------------- + + -- Call this only when holding Self_ID locked + + procedure Wait_For_Completion + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link) + is + begin + pragma Assert (Self_ID = Entry_Call.Self); + Self_ID.Common.State := Entry_Caller_Sleep; + + STPO.Sleep (Self_ID, Entry_Caller_Sleep); + + Self_ID.Common.State := Runnable; + end Wait_For_Completion; + + -------------------------------------- + -- Wait_For_Completion_With_Timeout -- + -------------------------------------- + + -- This routine will lock Self_ID. + + -- This procedure waits for the entry call to + -- be served, with a timeout. It tries to cancel the + -- call if the timeout expires before the call is served. + + -- If we wake up from the timed sleep operation here, + -- it may be for the following possible reasons: + + -- 1) The entry call is done being served. + -- 2) The timeout has expired (Timedout = True) + + -- Once the timeout has expired we may need to continue to wait if + -- the call is already being serviced. In that case, we want to go + -- back to sleep, but without any timeout. The variable Timedout is + -- used to control this. If the Timedout flag is set, we do not need + -- to Sleep with a timeout. We just sleep until we get a wakeup for + -- some status change. + + procedure Wait_For_Completion_With_Timeout + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + Wakeup_Time : Duration; + Mode : Delay_Modes) + is + Timedout : Boolean; + Yielded : Boolean; + + use type Ada.Exceptions.Exception_Id; + + begin + STPO.Write_Lock (Self_ID); + + pragma Assert (Entry_Call.Self = Self_ID); + pragma Assert (Entry_Call.Mode = Timed_Call); + Self_ID.Common.State := Entry_Caller_Sleep; + + STPO.Timed_Sleep + (Self_ID, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); + + if Timedout then + Entry_Call.State := Cancelled; + else + Entry_Call.State := Done; + end if; + + Self_ID.Common.State := Runnable; + STPO.Unlock (Self_ID); + end Wait_For_Completion_With_Timeout; + + ------------------------- + -- Wakeup_Entry_Caller -- + ------------------------- + + -- This is called at the end of service of an entry call, to abort the + -- caller if he is in an abortable part, and to wake up the caller if it + -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. + + -- (This enforces the rule that a task must be off-queue if its state is + -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. + + -- Timed_Call or Simple_Call: + -- The caller is waiting on Entry_Caller_Sleep, in + -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. + + -- Conditional_Call: + -- The caller might be in Wait_For_Completion, + -- waiting for a rendezvous (possibly requeued without abort) + -- to complete. + + procedure Wakeup_Entry_Caller + (Self_ID : Task_ID; + Entry_Call : Entry_Call_Link; + New_State : Entry_Call_State) + is + Caller : constant Task_ID := Entry_Call.Self; + begin + pragma Assert (New_State = Done or else New_State = Cancelled); + pragma Assert + (Caller.Common.State /= Terminated and then + Caller.Common.State /= Unactivated); + + Entry_Call.State := New_State; + STPO.Wakeup (Caller, Entry_Caller_Sleep); + end Wakeup_Entry_Caller; + + ----------------------- + -- Restricted GNARLI -- + ----------------------- + + -------------------------------- + -- Complete_Single_Entry_Body -- + -------------------------------- + + procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is + begin + -- Nothing needs to be done since + -- Object.Call_In_Progress.Exception_To_Raise has already been set to + -- Null_Id + null; + end Complete_Single_Entry_Body; + + -------------------------------------------- + -- Exceptional_Complete_Single_Entry_Body -- + -------------------------------------------- + + procedure Exceptional_Complete_Single_Entry_Body + (Object : Protection_Entry_Access; + Ex : Ada.Exceptions.Exception_Id) is + begin + Object.Call_In_Progress.Exception_To_Raise := Ex; + end Exceptional_Complete_Single_Entry_Body; + + --------------------------------- + -- Initialize_Protection_Entry -- + --------------------------------- + + procedure Initialize_Protection_Entry + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access) + is + Init_Priority : Integer := Ceiling_Priority; + + begin + if Init_Priority = Unspecified_Priority then + Init_Priority := System.Priority'Last; + end if; + + STPO.Initialize_Lock (Init_Priority, Object.L'Access); + Object.Ceiling := System.Any_Priority (Init_Priority); + Object.Compiler_Info := Compiler_Info; + Object.Call_In_Progress := null; + Object.Entry_Body := Entry_Body; + Object.Entry_Queue := null; + end Initialize_Protection_Entry; + + ---------------- + -- Lock_Entry -- + ---------------- + + -- Compiler interface only. + -- Do not call this procedure from within the run-time system. + + procedure Lock_Entry (Object : Protection_Entry_Access) is + Ceiling_Violation : Boolean; + begin + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + end Lock_Entry; + + -------------------------- + -- Lock_Read_Only_Entry -- + -------------------------- + + -- Compiler interface only. + -- Do not call this procedure from within the runtime system. + + procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is + Ceiling_Violation : Boolean; + begin + STPO.Read_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + end Lock_Read_Only_Entry; + + -------------------- + -- PO_Do_Or_Queue -- + -------------------- + + procedure PO_Do_Or_Queue + (Self_Id : Task_ID; + Object : Protection_Entry_Access; + Entry_Call : Entry_Call_Link) + is + Barrier_Value : Boolean; + begin + -- When the Action procedure for an entry body returns, it must be + -- completed (having called [Exceptional_]Complete_Entry_Body). + + Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); + + if Barrier_Value then + if Object.Call_In_Progress /= null then + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Self_Id, Entry_Call); + return; + end if; + + Object.Call_In_Progress := Entry_Call; + Object.Entry_Body.Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); + Object.Call_In_Progress := null; + Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + + elsif Entry_Call.Mode /= Conditional_Call then + Object.Entry_Queue := Entry_Call; + else + -- Conditional_Call + + STPO.Write_Lock (Entry_Call.Self); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); + STPO.Unlock (Entry_Call.Self); + end if; + + exception -- not needed in no exc mode + when others => -- not needed in no exc mode + Send_Program_Error -- not needed in no exc mode + (Self_Id, Entry_Call); -- not needed in no exc mode + end PO_Do_Or_Queue; + + ---------------------------- + -- Protected_Single_Count -- + ---------------------------- + + function Protected_Count_Entry + (Object : Protection_Entry) return Natural is + begin + if Object.Call_In_Progress /= null then + return 1; + else + return 0; + end if; + end Protected_Count_Entry; + + --------------------------------- + -- Protected_Single_Entry_Call -- + --------------------------------- + + procedure Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Mode : Call_Modes) + is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); + Ceiling_Violation : Boolean; + + begin + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + + Entry_Call.Mode := Mode; + Entry_Call.State := Now_Abortable; + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); + Unlock_Entry (Object); + + -- The call is either `Done' or not. It cannot be cancelled since there + -- is no ATC construct. + + pragma Assert (Entry_Call.State /= Cancelled); + + if Entry_Call.State = Done then + Check_Exception (Self_Id, Entry_Call'Access); + return; + end if; + + STPO.Write_Lock (Self_Id); + Wait_For_Completion (Self_Id, Entry_Call'Access); + STPO.Unlock (Self_Id); + Check_Exception (Self_Id, Entry_Call'Access); + end Protected_Single_Entry_Call; + + ----------------------------------- + -- Protected_Single_Entry_Caller -- + ----------------------------------- + + function Protected_Single_Entry_Caller + (Object : Protection_Entry) return Task_ID is + begin + return Object.Call_In_Progress.Self; + end Protected_Single_Entry_Caller; + + ------------------- + -- Service_Entry -- + ------------------- + + procedure Service_Entry (Object : Protection_Entry_Access) is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Link; + Caller : Task_ID; + Barrier_Value : Boolean; + + begin + Entry_Call := Object.Entry_Queue; + + if Entry_Call /= null then + Barrier_Value := + Object.Entry_Body.Barrier (Object.Compiler_Info, 1); + + if Barrier_Value then + if Object.Call_In_Progress /= null then + + -- This violates the No_Entry_Queue restriction, send + -- Program_Error to the caller. + + Send_Program_Error (Self_Id, Entry_Call); + return; + end if; + + Object.Call_In_Progress := Entry_Call; + Object.Entry_Body.Action + (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); + Object.Call_In_Progress := null; + Caller := Entry_Call.Self; + STPO.Write_Lock (Caller); + Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); + STPO.Unlock (Caller); + end if; + end if; + + exception -- not needed in no exc mode + when others => -- not needed in no exc mode + Send_Program_Error -- not needed in no exc mode + (Self_Id, Entry_Call); -- not needed in no exc mode + end Service_Entry; + + --------------------------------------- + -- Timed_Protected_Single_Entry_Call -- + --------------------------------------- + + -- Compiler interface only. Do not call from within the RTS. + + procedure Timed_Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean) + is + Self_Id : constant Task_ID := STPO.Self; + Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); + Ceiling_Violation : Boolean; + + begin + STPO.Write_Lock (Object.L'Access, Ceiling_Violation); + + if Ceiling_Violation then + raise Program_Error; + end if; + + Entry_Call.Mode := Timed_Call; + Entry_Call.State := Now_Abortable; + Entry_Call.Uninterpreted_Data := Uninterpreted_Data; + Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; + + PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); + Unlock_Entry (Object); + + -- Try to avoid waiting for completed calls. + -- The call is either `Done' or not. It cannot be cancelled since there + -- is no ATC construct and the timed wait has not started yet. + + pragma Assert (Entry_Call.State /= Cancelled); + + if Entry_Call.State = Done then + Check_Exception (Self_Id, Entry_Call'Access); + Entry_Call_Successful := True; + return; + end if; + + Wait_For_Completion_With_Timeout + (Self_Id, Entry_Call'Access, Timeout, Mode); + + pragma Assert (Entry_Call.State >= Done); + + Check_Exception (Self_Id, Entry_Call'Access); + Entry_Call_Successful := Entry_Call.State = Done; + end Timed_Protected_Single_Entry_Call; + + ------------------ + -- Unlock_Entry -- + ------------------ + + procedure Unlock_Entry (Object : Protection_Entry_Access) is + begin + STPO.Unlock (Object.L'Access); + end Unlock_Entry; + +end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads new file mode 100644 index 00000000000..9ae62378065 --- /dev/null +++ b/gcc/ada/s-tposen.ads @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . -- +-- S I N G L E _ E N T R Y -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an optimized version of Protected_Objects.Operations +-- and Protected_Objects.Entries making the following assumptions: +-- +-- PO have only one entry +-- There is only one caller at a time (No_Entry_Queue) +-- There is no dynamic priority support (No_Dynamic_Priorities) +-- No Abort Statements +-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) +-- PO are at library level +-- None of the tasks will terminate (no need for finalization) +-- +-- This interface is intended to be used in the ravenscar profile, the +-- compiler is responsible for ensuring that the conditions mentioned above +-- are respected, except for the No_Entry_Queue restriction that is checked +-- dynamically in this package, since the check cannot be performed at compile +-- time, and is relatively cheap (see body). +-- +-- This package is part of the high level tasking interface used by the +-- compiler to expand Ada 95 tasking constructs into simpler run time calls +-- (aka GNARLI, GNU Ada Run-time Library Interface) +-- +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes +-- in exp_ch9.adb and possibly exp_ch7.adb + +package System.Tasking.Protected_Objects.Single_Entry is + pragma Elaborate_Body; + + --------------------------------- + -- Compiler Interface (GNARLI) -- + --------------------------------- + + -- The compiler will expand in the GNAT tree the following construct: + -- + -- protected PO is + -- entry E; + -- procedure P; + -- private + -- Open : Boolean := False; + -- end PO; + -- + -- protected body PO is + -- entry E when Open is + -- ...variable declarations... + -- begin + -- ...B... + -- end E; + -- + -- procedure P is + -- ...variable declarations... + -- begin + -- ...C... + -- end P; + -- end PO; + -- + -- as follows: + -- + -- protected type poT is + -- entry e; + -- procedure p; + -- private + -- open : boolean := false; + -- end poT; + -- type poTV is limited record + -- open : boolean := false; + -- _object : aliased protection_entry; + -- end record; + -- procedure poPT__E1s (O : address; P : address; E : + -- protected_entry_index); + -- function poPT__B2s (O : address; E : protected_entry_index) return + -- boolean; + -- procedure poPT__pN (_object : in out poTV); + -- procedure poPT__pP (_object : in out poTV); + -- poTA : aliased entry_body := ( + -- barrier => poPT__B2s'unrestricted_access, + -- action => poPT__E1s'unrestricted_access); + -- freeze poTV [ + -- procedure _init_proc (_init : in out poTV) is + -- begin + -- _init.open := false; + -- _init_proc (_init._object); + -- initialize_protection_entry (_init._object'unchecked_access, + -- unspecified_priority, _init'address, poTA' + -- unrestricted_access); + -- return; + -- end _init_proc; + -- ] + -- po : poT; + -- _init_proc (poTV!(po)); + -- + -- function poPT__B2s (O : address; E : protected_entry_index) return + -- boolean is + -- type poTVP is access poTV; + -- _object : poTVP := poTVP!(O); + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- begin + -- return open; + -- end poPT__B2s; + -- + -- procedure poPT__E1s (O : address; P : address; E : + -- protected_entry_index) is + -- type poTVP is access poTV; + -- _object : poTVP := poTVP!(O); + -- begin + -- B1b : declare + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...B... + -- end B1b; + -- complete_single_entry_body (_object._object'unchecked_access); + -- return; + -- exception + -- when all others => + -- exceptional_complete_single_entry_body (_object._object' + -- unchecked_access, get_gnat_exception); + -- return; + -- end poPT__E1s; + -- + -- procedure poPT__pN (_object : in out poTV) is + -- poR : protection_entry renames _object._object; + -- openP : boolean renames _object.open; + -- ...variable declarations... + -- begin + -- ...C... + -- return; + -- end poPT__pN; + -- + -- procedure poPT__pP (_object : in out poTV) is + -- procedure _clean is + -- begin + -- service_entry (_object._object'unchecked_access); + -- unlock_entry (_object._object'unchecked_access); + -- return; + -- end _clean; + -- begin + -- lock_entry (_object._object'unchecked_access); + -- B5b : begin + -- poPT__pN (_object); + -- at end + -- _clean; + -- end B5b; + -- return; + -- end poPT__pP; + + type Protection_Entry is limited private; + -- This type contains the GNARL state of a protected object. The + -- application-defined portion of the state (i.e. private objects) + -- is maintained by the compiler-generated code. + + type Protection_Entry_Access is access all Protection_Entry; + + procedure Initialize_Protection_Entry + (Object : Protection_Entry_Access; + Ceiling_Priority : Integer; + Compiler_Info : System.Address; + Entry_Body : Entry_Body_Access); + -- Initialize the Object parameter so that it can be used by the run time + -- to keep track of the runtime state of a protected object. + + procedure Lock_Entry (Object : Protection_Entry_Access); + -- Lock a protected object for write access. Upon return, the caller + -- owns the lock to this object, and no other call to Lock or + -- Lock_Read_Only with the same argument will return until the + -- corresponding call to Unlock has been made by the caller. + + procedure Lock_Read_Only_Entry + (Object : Protection_Entry_Access); + -- Lock a protected object for read access. Upon return, the caller + -- owns the lock for read access, and no other calls to Lock + -- with the same argument will return until the corresponding call + -- to Unlock has been made by the caller. Other cals to Lock_Read_Only + -- may (but need not) return before the call to Unlock, and the + -- corresponding callers will also own the lock for read access. + + procedure Unlock_Entry (Object : Protection_Entry_Access); + -- Relinquish ownership of the lock for the object represented by + -- the Object parameter. If this ownership was for write access, or + -- if it was for read access where there are no other read access + -- locks outstanding, one (or more, in the case of Lock_Read_Only) + -- of the tasks waiting on this lock (if any) will be given the + -- lock and allowed to return from the Lock or Lock_Read_Only call. + + procedure Service_Entry (Object : Protection_Entry_Access); + -- Service the entry queue of the specified object, executing the + -- corresponding body of any queued entry call that is waiting on True + -- barrier. This is used when the state of a protected object may have + -- changed, in particular after the execution of the statement sequence of + -- a protected procedure. + -- This must be called with abortion deferred and with the corresponding + -- object locked. + + procedure Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Mode : Call_Modes); + -- Make a protected entry call to the specified object. + -- Pend a protected entry call on the protected object represented + -- by Object. A pended call is not queued; it may be executed immediately + -- or queued, depending on the state of the entry barrier. + -- + -- Uninterpreted_Data + -- This will be returned by Next_Entry_Call when this call is serviced. + -- It can be used by the compiler to pass information between the + -- caller and the server, in particular entry parameters. + -- + -- Mode + -- The kind of call to be pended + + procedure Timed_Protected_Single_Entry_Call + (Object : Protection_Entry_Access; + Uninterpreted_Data : System.Address; + Timeout : Duration; + Mode : Delay_Modes; + Entry_Call_Successful : out Boolean); + -- Same as the Protected_Entry_Call but with time-out specified. + -- This routine is used to implement timed entry calls. + + procedure Complete_Single_Entry_Body + (Object : Protection_Entry_Access); + pragma Inline (Complete_Single_Entry_Body); + -- Called from within an entry body procedure, indicates that the + -- corresponding entry call has been serviced. + + procedure Exceptional_Complete_Single_Entry_Body + (Object : Protection_Entry_Access; + Ex : Ada.Exceptions.Exception_Id); + -- Perform all of the functions of Complete_Entry_Body. In addition, + -- report in Ex the exception whose propagation terminated the entry + -- body to the runtime system. + + function Protected_Count_Entry (Object : Protection_Entry) + return Natural; + -- Return the number of entry calls on Object (0 or 1). + + function Protected_Single_Entry_Caller (Object : Protection_Entry) + return Task_ID; + -- Return value of E'Caller, where E is the protected entry currently + -- being handled. This will only work if called from within an + -- entry body, as required by the LRM (C.7.1(14)). + +private + type Protection_Entry is record + L : aliased Task_Primitives.Lock; + Compiler_Info : System.Address; + Call_In_Progress : Entry_Call_Link; + Ceiling : System.Any_Priority; + Entry_Body : Entry_Body_Access; + Entry_Queue : Entry_Call_Link; + end record; + pragma Volatile (Protection_Entry); + for Protection_Entry'Alignment use Standard'Maximum_Alignment; + -- Use maximum alignement so that one can convert a protection_entry_access + -- to a task_id. + +end System.Tasking.Protected_Objects.Single_Entry; diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb new file mode 100644 index 00000000000..65d6cd0df9f --- /dev/null +++ b/gcc/ada/s-traceb.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package + +package body System.Traceback is + + ------------------ + -- C_Call_Chain -- + ------------------ + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) + return Natural + is + Val : Natural; + + begin + Call_Chain (Traceback, Max_Len, Val); + return Val; + end C_Call_Chain; + + ---------------- + -- Call_Chain -- + ---------------- + + function Backtrace + (Traceback : System.Address; + Len : Integer; + Exclude_Min : System.Address; + Exclude_Max : System.Address) + return Integer; + pragma Import (C, Backtrace, "__gnat_backtrace"); + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min, + Exclude_Max : System.Address := System.Null_Address) + is + begin + Len := Backtrace (Traceback, Max_Len, Exclude_Min, Exclude_Max); + end Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads new file mode 100644 index 00000000000..13f0e88728d --- /dev/null +++ b/gcc/ada/s-traceb.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a method for generating a traceback of the +-- current execution location. The traceback shows the locations of +-- calls in the call chain, up to either the top or a designated +-- number of levels. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +package System.Traceback is + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address); + -- Store up to Max_Len code locations in Traceback, corresponding to + -- the current call chain. + -- + -- Traceback is the address of an array of addresses where the + -- result will be stored. + -- + -- Max_Len is the length of the Traceback array. If the call chain + -- is longer than this, then additional entries are discarded, and + -- the traceback is missing some of the highest level entries. + -- + -- Len is the returned actual number of addresses stored + -- in the Traceback array. + -- + -- Exclude_Min/Exclude_Max, if non null, provide a range of addresses + -- to ignore from the computation of the traceback. + -- + -- On return, the Traceback array is filled in, and Len indicates + -- the number of stored entries. The first entry is the most recent + -- call, and the last entry is the highest level call. + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) + return Natural; + pragma Export (C, C_Call_Chain, "system__traceback__c_call_chain"); + -- Version that can be used directly from C. + +end System.Traceback; diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads new file mode 100644 index 00000000000..0b315a84c1f --- /dev/null +++ b/gcc/ada/s-unstyp.ads @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . U N S I G N E D _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains definitions of standard unsigned types that +-- correspond in size to the standard signed types declared in Standard. +-- and (unlike the types in Interfaces have corresponding names). It +-- also contains some related definitions for other specialized types +-- used only by the expander. + +package System.Unsigned_Types is +pragma Pure (Unsigned_Types); + + type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; + type Short_Unsigned is mod 2 ** Short_Integer'Size; + type Unsigned is mod 2 ** Integer'Size; + type Long_Unsigned is mod 2 ** Long_Integer'Size; + type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; + + type Float_Unsigned is mod 2 ** Float'Size; + -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) + + type Packed_Byte is mod 2 ** 8; + for Packed_Byte'Size use 8; + -- Component type for Packed_Butes array + + type Packed_Bytes1 is array (Natural range <>) of Packed_Byte; + for Packed_Bytes1'Alignment use 1; + -- This is the type used to implement packed arrays where no alignment + -- is required. This includes the cases of 1,2,4 (where we use direct + -- masking operations), and all odd component sizes (where the clusters + -- are not aligned anyway, see, e.g. System.Pack_07 in file s-pack07 + -- for details. + + type Packed_Bytes2 is new Packed_Bytes1; + for Packed_Bytes2'Alignment use 2; + -- This is the type used to implement packed arrays where an alignment + -- of 2 is helpful for maximum efficiency of the get and set routines + -- in the corresponding library unit. This is true of all component + -- sizes that are even but not divisible by 4 (other than 2 for which + -- we use direct masking operations). In such cases, the clusters can + -- be assumed to be 2-byte aligned if the array is aligned. See for + -- example System.Pack_10 in file s-pack10). + + type Packed_Bytes4 is new Packed_Bytes1; + for Packed_Bytes4'Alignment use Integer'Min (4, Standard'Maximum_Alignment); + -- This is the type used to implement packed arrays where an alignment + -- of 4 is helpful for maximum efficiency of the get and set routines + -- in the corresponding library unit. This is true of all component + -- sizes that are divisible by 4 (other than powers of 2, which are + -- either handled by direct masking or not packed at all). In such cases + -- the clusters can be assumed to be 4-byte aligned if the array is + -- aligned (see System.Pack_12 in file s-pack12 as an example). + + type Bits_1 is mod 2**1; + type Bits_2 is mod 2**2; + type Bits_4 is mod 2**4; + -- Types used for packed array conversions + + subtype Bytes_F is Packed_Bytes4 (1 .. Float'Size / 8); + -- Type used in implementation of Is_Negative instrinsic (see Exp_Intr) + + function Shift_Left + (Value : Short_Short_Unsigned; + Amount : Natural) + return Short_Short_Unsigned; + + function Shift_Right + (Value : Short_Short_Unsigned; + Amount : Natural) + return Short_Short_Unsigned; + + function Shift_Right_Arithmetic + (Value : Short_Short_Unsigned; + Amount : Natural) + return Short_Short_Unsigned; + + function Rotate_Left + (Value : Short_Short_Unsigned; + Amount : Natural) + return Short_Short_Unsigned; + + function Rotate_Right + (Value : Short_Short_Unsigned; + Amount : Natural) + return Short_Short_Unsigned; + + function Shift_Left + (Value : Short_Unsigned; + Amount : Natural) + return Short_Unsigned; + + function Shift_Right + (Value : Short_Unsigned; + Amount : Natural) + return Short_Unsigned; + + function Shift_Right_Arithmetic + (Value : Short_Unsigned; + Amount : Natural) + return Short_Unsigned; + + function Rotate_Left + (Value : Short_Unsigned; + Amount : Natural) + return Short_Unsigned; + + function Rotate_Right + (Value : Short_Unsigned; + Amount : Natural) + return Short_Unsigned; + + function Shift_Left + (Value : Unsigned; + Amount : Natural) + return Unsigned; + + function Shift_Right + (Value : Unsigned; + Amount : Natural) + return Unsigned; + + function Shift_Right_Arithmetic + (Value : Unsigned; + Amount : Natural) + return Unsigned; + + function Rotate_Left + (Value : Unsigned; + Amount : Natural) + return Unsigned; + + function Rotate_Right + (Value : Unsigned; + Amount : Natural) + return Unsigned; + + function Shift_Left + (Value : Long_Unsigned; + Amount : Natural) + return Long_Unsigned; + + function Shift_Right + (Value : Long_Unsigned; + Amount : Natural) + return Long_Unsigned; + + function Shift_Right_Arithmetic + (Value : Long_Unsigned; + Amount : Natural) + return Long_Unsigned; + + function Rotate_Left + (Value : Long_Unsigned; + Amount : Natural) + return Long_Unsigned; + + function Rotate_Right + (Value : Long_Unsigned; + Amount : Natural) + return Long_Unsigned; + + function Shift_Left + (Value : Long_Long_Unsigned; + Amount : Natural) + return Long_Long_Unsigned; + + function Shift_Right + (Value : Long_Long_Unsigned; + Amount : Natural) + return Long_Long_Unsigned; + + function Shift_Right_Arithmetic + (Value : Long_Long_Unsigned; + Amount : Natural) + return Long_Long_Unsigned; + + function Rotate_Left + (Value : Long_Long_Unsigned; + Amount : Natural) + return Long_Long_Unsigned; + + function Rotate_Right + (Value : Long_Long_Unsigned; + Amount : Natural) + return Long_Long_Unsigned; + + pragma Import (Intrinsic, Shift_Left); + pragma Import (Intrinsic, Shift_Right); + pragma Import (Intrinsic, Shift_Right_Arithmetic); + pragma Import (Intrinsic, Rotate_Left); + pragma Import (Intrinsic, Rotate_Right); + + -- The following definitions are obsolsecent. They were needed by the + -- previous version of the compiler and runtime, but are not needed + -- by the current version. We retain them to help with bootstrap path + -- problems. Also they seem harmless, and if any user programs have + -- been (rather improperly) using these types, why discombobulate them? + + subtype Packed_Bytes is Packed_Bytes4; + subtype Packed_Bytes_Unaligned is Packed_Bytes1; + +end System.Unsigned_Types; diff --git a/gcc/ada/s-vaflop.adb b/gcc/ada/s-vaflop.adb new file mode 100644 index 00000000000..069188c6dc8 --- /dev/null +++ b/gcc/ada/s-vaflop.adb @@ -0,0 +1,421 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.20 $ +-- -- +-- Copyright (C) 1997-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 is a dummy body for use on non-Alpha systems so that the library +-- can compile. This dummy version uses ordinary conversions and other +-- arithmetic operations. it is used only for testing purposes in the +-- case where the -gnatdm switch is used to force testing of VMS features +-- on non-VMS systems. + +with System.IO; use System.IO; + +package body System.Vax_Float_Operations is + + ----------- + -- Abs_F -- + ----------- + + function Abs_F (X : F) return F is + begin + return abs X; + end Abs_F; + + ----------- + -- Abs_G -- + ----------- + + function Abs_G (X : G) return G is + begin + return abs X; + end Abs_G; + + ----------- + -- Add_F -- + ----------- + + function Add_F (X, Y : F) return F is + begin + return X + Y; + end Add_F; + + ----------- + -- Add_G -- + ----------- + + function Add_G (X, Y : G) return G is + begin + return X + Y; + end Add_G; + + ------------ + -- D_To_G -- + ------------ + + function D_To_G (X : D) return G is + begin + return G (X); + end D_To_G; + + -------------------- + -- Debug_Output_D -- + -------------------- + + procedure Debug_Output_D (Arg : D) is + begin + Put (D'Image (Arg)); + end Debug_Output_D; + + -------------------- + -- Debug_Output_F -- + -------------------- + + procedure Debug_Output_F (Arg : F) is + begin + Put (F'Image (Arg)); + end Debug_Output_F; + + -------------------- + -- Debug_Output_G -- + -------------------- + + procedure Debug_Output_G (Arg : G) is + begin + Put (G'Image (Arg)); + end Debug_Output_G; + + -------------------- + -- Debug_String_D -- + -------------------- + + Debug_String_Buffer : String (1 .. 32); + -- Buffer used by all Debug_String_x routines for returning result + + function Debug_String_D (Arg : D) return System.Address is + Image_String : constant String := D'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_D; + + -------------------- + -- Debug_String_F -- + -------------------- + + function Debug_String_F (Arg : F) return System.Address is + Image_String : constant String := F'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_F; + + -------------------- + -- Debug_String_G -- + -------------------- + + function Debug_String_G (Arg : G) return System.Address is + Image_String : constant String := G'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_G; + + ----------- + -- Div_F -- + ----------- + + function Div_F (X, Y : F) return F is + begin + return X / Y; + end Div_F; + + ----------- + -- Div_G -- + ----------- + + function Div_G (X, Y : G) return G is + begin + return X / Y; + end Div_G; + + ---------- + -- Eq_F -- + ---------- + + function Eq_F (X, Y : F) return Boolean is + begin + return X = Y; + end Eq_F; + + ---------- + -- Eq_G -- + ---------- + + function Eq_G (X, Y : G) return Boolean is + begin + return X = Y; + end Eq_G; + + ------------ + -- F_To_G -- + ------------ + + function F_To_G (X : F) return G is + begin + return G (X); + end F_To_G; + + ------------ + -- F_To_Q -- + ------------ + + function F_To_Q (X : F) return Q is + begin + return Q (X); + end F_To_Q; + + ------------ + -- F_To_S -- + ------------ + + function F_To_S (X : F) return S is + begin + return S (X); + end F_To_S; + + ------------ + -- G_To_D -- + ------------ + + function G_To_D (X : G) return D is + begin + return D (X); + end G_To_D; + + ------------ + -- G_To_F -- + ------------ + + function G_To_F (X : G) return F is + begin + return F (X); + end G_To_F; + + ------------ + -- G_To_Q -- + ------------ + + function G_To_Q (X : G) return Q is + begin + return Q (X); + end G_To_Q; + + ------------ + -- G_To_T -- + ------------ + + function G_To_T (X : G) return T is + begin + return T (X); + end G_To_T; + + ---------- + -- Le_F -- + ---------- + + function Le_F (X, Y : F) return Boolean is + begin + return X <= Y; + end Le_F; + + ---------- + -- Le_G -- + ---------- + + function Le_G (X, Y : G) return Boolean is + begin + return X <= Y; + end Le_G; + + ---------- + -- Lt_F -- + ---------- + + function Lt_F (X, Y : F) return Boolean is + begin + return X < Y; + end Lt_F; + + ---------- + -- Lt_G -- + ---------- + + function Lt_G (X, Y : G) return Boolean is + begin + return X < Y; + end Lt_G; + + ----------- + -- Mul_F -- + ----------- + + function Mul_F (X, Y : F) return F is + begin + return X * Y; + end Mul_F; + + ----------- + -- Mul_G -- + ----------- + + function Mul_G (X, Y : G) return G is + begin + return X * Y; + end Mul_G; + + ----------- + -- Neg_F -- + ----------- + + function Neg_F (X : F) return F is + begin + return -X; + end Neg_F; + + ----------- + -- Neg_G -- + ----------- + + function Neg_G (X : G) return G is + begin + return -X; + end Neg_G; + + -------- + -- pd -- + -------- + + procedure pd (Arg : D) is + begin + Put_Line (D'Image (Arg)); + end pd; + + -------- + -- pf -- + -------- + + procedure pf (Arg : F) is + begin + Put_Line (F'Image (Arg)); + end pf; + + -------- + -- pg -- + -------- + + procedure pg (Arg : G) is + begin + Put_Line (G'Image (Arg)); + end pg; + + ------------ + -- Q_To_F -- + ------------ + + function Q_To_F (X : Q) return F is + begin + return F (X); + end Q_To_F; + + ------------ + -- Q_To_G -- + ------------ + + function Q_To_G (X : Q) return G is + begin + return G (X); + end Q_To_G; + + ------------ + -- S_To_F -- + ------------ + + function S_To_F (X : S) return F is + begin + return F (X); + end S_To_F; + + ----------- + -- Sub_F -- + ----------- + + function Sub_F (X, Y : F) return F is + begin + return X - Y; + end Sub_F; + + ----------- + -- Sub_G -- + ----------- + + function Sub_G (X, Y : G) return G is + begin + return X - Y; + end Sub_G; + + ------------ + -- T_To_D -- + ------------ + + function T_To_D (X : T) return D is + begin + return G_To_D (T_To_G (X)); + end T_To_D; + + ------------ + -- T_To_G -- + ------------ + + function T_To_G (X : T) return G is + begin + return G (X); + end T_To_G; + +end System.Vax_Float_Operations; diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads new file mode 100644 index 00000000000..5f22cffdc04 --- /dev/null +++ b/gcc/ada/s-vaflop.ads @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.13 $ -- +-- -- +-- Copyright (C) 1997-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 contains runtime routines for handling the non-IEEE +-- floating-point formats used on the Vax and the Alpha. + +package System.Vax_Float_Operations is + + pragma Warnings (Off); + -- Suppress warnings if not on Alpha/VAX + + type D is digits 9; + pragma Float_Representation (VAX_Float, D); + -- D Float type on Vax + + type G is digits 15; + pragma Float_Representation (VAX_Float, G); + -- G Float type on Vax + + type F is digits 6; + pragma Float_Representation (VAX_Float, F); + -- F Float type on Vax + + type S is digits 6; + pragma Float_Representation (IEEE_Float, S); + -- IEEE short + + type T is digits 15; + pragma Float_Representation (IEEE_Float, T); + -- IEEE long + + pragma Warnings (On); + + type Q is range -2 ** 63 .. +(2 ** 63 - 1); + -- 64-bit signed integer + + -------------------------- + -- Conversion Functions -- + -------------------------- + + function D_To_G (X : D) return G; + function G_To_D (X : G) return D; + -- Conversions between D float and G float + + function G_To_F (X : G) return F; + function F_To_G (X : F) return G; + -- Conversions between F float and G float + + function F_To_S (X : F) return S; + function S_To_F (X : S) return F; + -- Conversions between F float and IEEE short + + function G_To_T (X : G) return T; + function T_To_G (X : T) return G; + -- Conversions between G float and IEEE long + + function F_To_Q (X : F) return Q; + function Q_To_F (X : Q) return F; + -- Conversions between F float and 64-bit integer + + function G_To_Q (X : G) return Q; + function Q_To_G (X : Q) return G; + -- Conversions between G float and 64-bit integer + + function T_To_D (X : T) return D; + -- Conversion from IEEE long to D_Float (used for literals) + + -------------------------- + -- Arithmetic Functions -- + -------------------------- + + function Abs_F (X : F) return F; + function Abs_G (X : G) return G; + -- Absolute value of F/G float + + function Add_F (X, Y : F) return F; + function Add_G (X, Y : G) return G; + -- Addition of F/G float + + function Div_F (X, Y : F) return F; + function Div_G (X, Y : G) return G; + -- Division of F/G float + + function Mul_F (X, Y : F) return F; + function Mul_G (X, Y : G) return G; + -- Multiplication of F/G float + + function Neg_F (X : F) return F; + function Neg_G (X : G) return G; + -- Negation of F/G float + + function Sub_F (X, Y : F) return F; + function Sub_G (X, Y : G) return G; + -- Subtraction of F/G float + + -------------------------- + -- Comparison Functions -- + -------------------------- + + function Eq_F (X, Y : F) return Boolean; + function Eq_G (X, Y : G) return Boolean; + -- Compares for X = Y + + function Le_F (X, Y : F) return Boolean; + function Le_G (X, Y : G) return Boolean; + -- Compares for X <= Y + + function Lt_F (X, Y : F) return Boolean; + function Lt_G (X, Y : G) return Boolean; + -- Compares for X < Y + + ---------------------- + -- Debug Procedures -- + ---------------------- + + procedure Debug_Output_D (Arg : D); + procedure Debug_Output_F (Arg : F); + procedure Debug_Output_G (Arg : G); + pragma Export (Ada, Debug_Output_D); + pragma Export (Ada, Debug_Output_F); + pragma Export (Ada, Debug_Output_G); + -- These routines output their argument in decimal string form, with + -- no terminating line return. They are provided for implicit use by + -- the pre gnat-3.12w GDB, and are retained for backwards compatibility. + + function Debug_String_D (Arg : D) return System.Address; + function Debug_String_F (Arg : F) return System.Address; + function Debug_String_G (Arg : G) return System.Address; + pragma Export (Ada, Debug_String_D); + pragma Export (Ada, Debug_String_F); + pragma Export (Ada, Debug_String_G); + -- These routines return a decimal C string image of their argument. + -- They are provided for implicit use by the debugger, in response to + -- the special encoding used for Vax floating-point types (see Exp_Dbug + -- for details). They supercede the above Debug_Output_D/F/G routines + -- which didn't work properly with GDBTK. + + procedure pd (Arg : D); + procedure pf (Arg : F); + procedure pg (Arg : G); + pragma Export (Ada, pd); + pragma Export (Ada, pf); + pragma Export (Ada, pg); + -- These are like the Debug_Output_D/F/G procedures except that they + -- output a line return after the output. They were originally present + -- for direct use in GDB before GDB recognized Vax floating-point + -- types, and are retained for backwards compatibility. + +private + pragma Inline (D_To_G); + pragma Inline (F_To_G); + pragma Inline (F_To_Q); + pragma Inline (F_To_S); + pragma Inline (G_To_D); + pragma Inline (G_To_F); + pragma Inline (G_To_Q); + pragma Inline (G_To_T); + pragma Inline (Q_To_F); + pragma Inline (Q_To_G); + pragma Inline (S_To_F); + pragma Inline (T_To_G); + + pragma Inline (Abs_F); + pragma Inline (Abs_G); + pragma Inline (Add_F); + pragma Inline (Add_G); + pragma Inline (Div_G); + pragma Inline (Div_F); + pragma Inline (Mul_F); + pragma Inline (Mul_G); + pragma Inline (Neg_G); + pragma Inline (Neg_F); + pragma Inline (Sub_F); + pragma Inline (Sub_G); + + pragma Inline (Eq_F); + pragma Inline (Eq_G); + pragma Inline (Le_F); + pragma Inline (Le_G); + pragma Inline (Lt_F); + pragma Inline (Lt_G); + +end System.Vax_Float_Operations; diff --git a/gcc/ada/s-valboo.adb b/gcc/ada/s-valboo.adb new file mode 100644 index 00000000000..c74b07a91f8 --- /dev/null +++ b/gcc/ada/s-valboo.adb @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ B O O L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- 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.Val_Util; use System.Val_Util; + +package body System.Val_Bool is + + ------------------- + -- Value_Boolean -- + ------------------- + + function Value_Boolean (Str : String) return Boolean is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + begin + Normalize_String (S, F, L); + + if S (F .. L) = "TRUE" then + return True; + end if; + + if S (F .. L) = "FALSE" then + return False; + end if; + + raise Constraint_Error; + + -- Above should use elsif, but this doesn't work in GNAT version 1.81??? + + end Value_Boolean; + +end System.Val_Bool; diff --git a/gcc/ada/s-valboo.ads b/gcc/ada/s-valboo.ads new file mode 100644 index 00000000000..d28cb1b9a6e --- /dev/null +++ b/gcc/ada/s-valboo.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ B O O L -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +package System.Val_Bool is +pragma Pure (Val_Bool); + + function Value_Boolean (Str : String) return Boolean; + -- Computes Boolean'Value (Str). + +end System.Val_Bool; diff --git a/gcc/ada/s-valcha.adb b/gcc/ada/s-valcha.adb new file mode 100644 index 00000000000..31bcbd3e91c --- /dev/null +++ b/gcc/ada/s-valcha.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ -- +-- -- +-- 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.Val_Util; use System.Val_Util; + +package body System.Val_Char is + + --------------------- + -- Value_Character -- + --------------------- + + function Value_Character (Str : String) return Character is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + begin + Normalize_String (S, F, L); + + -- Accept any single character enclosed in quotes + + if L - F = 2 and then S (F) = ''' and then S (L) = ''' then + return Character'Val (Character'Pos (S (F + 1))); + + -- Check control character cases + + else + for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop + if S (F .. L) = Character'Image (C) then + return C; + end if; + end loop; + + for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop + if S (F .. L) = Character'Image (C) then + return C; + end if; + end loop; + + raise Constraint_Error; + end if; + + end Value_Character; + +end System.Val_Char; diff --git a/gcc/ada/s-valcha.ads b/gcc/ada/s-valcha.ads new file mode 100644 index 00000000000..4eba148d325 --- /dev/null +++ b/gcc/ada/s-valcha.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package System.Val_Char is +pragma Pure (Val_Char); + + function Value_Character (Str : String) return Character; + -- Computes Character'Value (Str). + +end System.Val_Char; diff --git a/gcc/ada/s-valdec.adb b/gcc/ada/s-valdec.adb new file mode 100644 index 00000000000..5ae8a502bbe --- /dev/null +++ b/gcc/ada/s-valdec.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ D E C -- +-- -- +-- 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 System.Val_Real; use System.Val_Real; + +package body System.Val_Dec is + + ------------------ + -- Scan_Decimal -- + ------------------ + + -- For decimal types where Size < Integer'Size, it is fine to use + -- the floating-point circuit, since it certainly has sufficient + -- precision for any reasonable hardware, and we just don't support + -- things on junk hardware! + + function Scan_Decimal + (Str : String; + Ptr : access Integer; + Max : Integer; + Scale : Integer) + return Integer + is + Val : Long_Long_Float; + + begin + Val := Scan_Real (Str, Ptr, Max); + return Integer (Val * 10.0 ** Scale); + end Scan_Decimal; + + ------------------- + -- Value_Decimal -- + ------------------- + + -- Again, we use the real circuit for this purpose + + function Value_Decimal (Str : String; Scale : Integer) return Integer is + begin + return Integer (Value_Real (Str) * 10.0 ** Scale); + end Value_Decimal; + +end System.Val_Dec; diff --git a/gcc/ada/s-valdec.ads b/gcc/ada/s-valdec.ads new file mode 100644 index 00000000000..38e8a326ede --- /dev/null +++ b/gcc/ada/s-valdec.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ D E C -- +-- -- +-- 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 contains routines for scanning decimal values where the size +-- of the type is no greater than Standard.Integer'Size, for use in Text_IO. +-- Decimal_IO, and the Value attribute for such decimal types. + +package System.Val_Dec is +pragma Pure (Val_Dec); + + function Scan_Decimal + (Str : String; + Ptr : access Integer; + Max : Integer; + Scale : Integer) + return Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal according to the syntax described in (RM 3.5(43)). The + -- substring scanned extends no further than Str (Max). There are three + -- cases for the return: + -- + -- If a valid real literal is found after scanning past any initial spaces, + -- then Ptr.all is updated past the last character of the literal (but + -- trailing spaces are not scanned out). The value returned is the value + -- Integer'Integer_Value (decimal-literal-value), using the given Scale + -- to determine this value. + -- + -- If no valid real literal is found, then Ptr.all points either to an + -- initial non-digit character, or to Max + 1 if the field is all spaces + -- and the exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the + -- pointer positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Decimal (Str : String; Scale : Integer) return Integer; + -- Used in computing X'Value (Str) where X is a decimal types whose size + -- does not exceed Standard.Integer'Size. Str is the string argument of + -- the attribute. Constraint_Error is raised if the string is malformed + -- or if the value is out of range, otherwise the value returned is the + -- value Integer'Integer_Value (decimal-literal-value), using the given + -- Scale to determine this value. + +end System.Val_Dec; diff --git a/gcc/ada/s-valenu.adb b/gcc/ada/s-valenu.adb new file mode 100644 index 00000000000..8c9a040c750 --- /dev/null +++ b/gcc/ada/s-valenu.adb @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.12 $ +-- -- +-- 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 Unchecked_Conversion; +with System.Val_Util; use System.Val_Util; + +package body System.Val_Enum is + + ------------------------- + -- Value_Enumeration_8 -- + ------------------------- + + function Value_Enumeration_8 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + Normalize_String (S, F, L); + + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + + raise Constraint_Error; + end Value_Enumeration_8; + + -------------------------- + -- Value_Enumeration_16 -- + -------------------------- + + function Value_Enumeration_16 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + Normalize_String (S, F, L); + + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + + raise Constraint_Error; + end Value_Enumeration_16; + + -------------------------- + -- Value_Enumeration_32 -- + -------------------------- + + function Value_Enumeration_32 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + Normalize_String (S, F, L); + + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + + raise Constraint_Error; + end Value_Enumeration_32; + +end System.Val_Enum; diff --git a/gcc/ada/s-valenu.ads b/gcc/ada/s-valenu.ads new file mode 100644 index 00000000000..e9c39115aad --- /dev/null +++ b/gcc/ada/s-valenu.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ +-- -- +-- 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 is used to compute the Value attribute for enumeration types +-- other than those in packages Standard and System. See unit Exp_Imgv for +-- details of the format of constructed image tables. + +package System.Val_Enum is +pragma Pure (Val_Enum); + + function Value_Enumeration_8 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural; + -- Used to compute Enum'Value (Str) where Enum is some enumeration type + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- number of enumeration literals in the type. The Indexes values are + -- the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)). + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. + -- + -- Str is the argument of the attribute function, and may have leading + -- and trailing spaces, and letters can be upper or lower case or mixed. + -- If the image is found in Names, then the corresponding Pos value is + -- returned. If not, Constraint_Error is raised. + + function Value_Enumeration_16 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural; + -- Identical to Value_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Value_Enumeration_32 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural; + -- Identical to Value_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + +end System.Val_Enum; diff --git a/gcc/ada/s-valint.adb b/gcc/ada/s-valint.adb new file mode 100644 index 00000000000..2807b767aa8 --- /dev/null +++ b/gcc/ada/s-valint.adb @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ I N T -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Uns; use System.Val_Uns; +with System.Val_Util; use System.Val_Util; + +package body System.Val_Int is + + ------------------ + -- Scan_Integer -- + ------------------ + + function Scan_Integer + (Str : String; + Ptr : access Integer; + Max : Integer) + return Integer + is + Uval : Unsigned; + -- Unsigned result + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False + + Start : Positive; + -- Saves location of first non-blank (not used in this case) + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + Uval := Scan_Unsigned (Str, Ptr, Max); + + -- Deal with overflow cases, and also with maximum negative number + + if Uval > Unsigned (Integer'Last) then + if Minus and then Uval = Unsigned (-(Integer'First)) then + return Integer'First; + else + raise Constraint_Error; + end if; + + -- Negative values + + elsif Minus then + return -(Integer (Uval)); + + -- Positive values + + else + return Integer (Uval); + end if; + + end Scan_Integer; + + ------------------- + -- Value_Integer -- + ------------------- + + function Value_Integer (Str : String) return Integer is + V : Integer; + P : aliased Integer := Str'First; + + begin + V := Scan_Integer (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end Value_Integer; + +end System.Val_Int; diff --git a/gcc/ada/s-valint.ads b/gcc/ada/s-valint.ads new file mode 100644 index 00000000000..b58b04c3e6e --- /dev/null +++ b/gcc/ada/s-valint.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ I N T -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- 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 routines for scanning signed Integer values for use +-- in Text_IO.Integer_IO, and the Value attribute. + +package System.Val_Int is +pragma Pure (Val_Int); + + function Scan_Integer + (Str : String; + Ptr : access Integer; + Max : Integer) + return Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Integer (Str : String) return Integer; + -- Used in computing X'Value (Str) where X is a signed integer type whose + -- base range does not exceed the base range of Integer. Str is the string + -- argument of the attribute. Constraint_Error is raised if the string is + -- malformed, or if the value is out of range. + +end System.Val_Int; diff --git a/gcc/ada/s-vallld.adb b/gcc/ada/s-vallld.adb new file mode 100644 index 00000000000..91610351850 --- /dev/null +++ b/gcc/ada/s-vallld.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L D -- +-- -- +-- 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 System.Val_Real; use System.Val_Real; + +package body System.Val_LLD is + + ---------------------------- + -- Scan_Long_Long_Decimal -- + ---------------------------- + + -- We use the floating-point circuit for now, this will be OK on a PC, + -- but definitely does NOT have the required precision if the longest + -- float type is IEEE double. This must be fixed in the future ??? + + function Scan_Long_Long_Decimal + (Str : String; + Ptr : access Integer; + Max : Integer; + Scale : Integer) + return Long_Long_Integer + is + Val : Long_Long_Float; + + begin + Val := Scan_Real (Str, Ptr, Max); + return Long_Long_Integer (Val * 10.0 ** Scale); + end Scan_Long_Long_Decimal; + + ----------------------------- + -- Value_Long_Long_Decimal -- + ----------------------------- + + -- Again we cheat and use floating-point ??? + + function Value_Long_Long_Decimal + (Str : String; + Scale : Integer) + return Long_Long_Integer + is + begin + return Long_Long_Integer (Value_Real (Str) * 10.0 ** Scale); + end Value_Long_Long_Decimal; + +end System.Val_LLD; diff --git a/gcc/ada/s-vallld.ads b/gcc/ada/s-vallld.ads new file mode 100644 index 00000000000..9e7b0a955d4 --- /dev/null +++ b/gcc/ada/s-vallld.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L D -- +-- -- +-- 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 contains routines for scanning decimal values where the size +-- of the type is greater than Standard.Integer'Size, for use in Text_IO. +-- Decimal_IO, and the Value attribute for such decimal types. + +package System.Val_LLD is +pragma Pure (Val_LLD); + + function Scan_Long_Long_Decimal + (Str : String; + Ptr : access Integer; + Max : Integer; + Scale : Integer) + return Long_Long_Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal according to the syntax described in (RM 3.5(43)). The + -- substring scanned extends no further than Str (Max). There are three + -- cases for the return: + -- + -- If a valid real literal is found after scanning past any initial spaces, + -- then Ptr.all is updated past the last character of the literal (but + -- trailing spaces are not scanned out). The value returned is the value + -- Long_Long_Integer'Integer_Value (decimal-literal-value), using the given + -- Scale to determine this value. + -- + -- If no valid real literal is found, then Ptr.all points either to an + -- initial non-digit character, or to Max + 1 if the field is all spaces + -- and the exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the + -- pointer positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Long_Long_Decimal + (Str : String; + Scale : Integer) + return Long_Long_Integer; + -- Used in computing X'Value (Str) where X is a decimal types whose size + -- exceeds Standard.Integer'Size. Str is the string argument of the + -- attribute. Constraint_Error is raised if the string is malformed + -- or if the value is out of range, otherwise the value returned is the + -- value Long_Long_Integer'Integer_Value (decimal-literal-value), using + -- the given Scale to determine this value. + +end System.Val_LLD; diff --git a/gcc/ada/s-vallli.adb b/gcc/ada/s-vallli.adb new file mode 100644 index 00000000000..902812ba017 --- /dev/null +++ b/gcc/ada/s-vallli.adb @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; +with System.Val_LLU; use System.Val_LLU; +with System.Val_Util; use System.Val_Util; + +package body System.Val_LLI is + + --------------------------- + -- Scn_Long_Long_Integer -- + --------------------------- + + function Scan_Long_Long_Integer + (Str : String; + Ptr : access Integer; + Max : Integer) + return Long_Long_Integer + is + Uval : Long_Long_Unsigned; + -- Unsigned result + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False + + Start : Positive; + -- Saves location of first non-blank (not used in this case) + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + Uval := Scan_Long_Long_Unsigned (Str, Ptr, Max); + + -- Deal with overflow cases, and also with maximum negative number + + if Uval > Long_Long_Unsigned (Long_Long_Integer'Last) then + if Minus + and then Uval = Long_Long_Unsigned (-(Long_Long_Integer'First)) then + return Long_Long_Integer'First; + else + raise Constraint_Error; + end if; + + -- Negative values + + elsif Minus then + return -(Long_Long_Integer (Uval)); + + -- Positive values + + else + return Long_Long_Integer (Uval); + end if; + + end Scan_Long_Long_Integer; + + ----------------------------- + -- Value_Long_Long_Integer -- + ----------------------------- + + function Value_Long_Long_Integer (Str : String) return Long_Long_Integer is + V : Long_Long_Integer; + P : aliased Integer := Str'First; + + begin + V := Scan_Long_Long_Integer (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + + end Value_Long_Long_Integer; + +end System.Val_LLI; diff --git a/gcc/ada/s-vallli.ads b/gcc/ada/s-vallli.ads new file mode 100644 index 00000000000..adbda0b0ef1 --- /dev/null +++ b/gcc/ada/s-vallli.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L I -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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 routines for scanning signed Long_Long_Integer +-- values for use in Text_IO.Integer_IO, and the Value attribute. + +package System.Val_LLI is +pragma Pure (Val_LLI); + + function Scan_Long_Long_Integer + (Str : String; + Ptr : access Integer; + Max : Integer) + return Long_Long_Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Long_Long_Integer (Str : String) return Long_Long_Integer; + -- Used in computing X'Value (Str) where X is a signed integer type whose + -- base range exceeds the base range of Integer. Str is the string argument + -- of the attribute. Constraint_Error is raised if the string is malformed, + -- or if the value is out of range. + +end System.Val_LLI; diff --git a/gcc/ada/s-valllu.adb b/gcc/ada/s-valllu.adb new file mode 100644 index 00000000000..444d0fd8110 --- /dev/null +++ b/gcc/ada/s-valllu.adb @@ -0,0 +1,304 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L U -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.12 $ -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; + +package body System.Val_LLU is + + ----------------------------- + -- Scan_Long_Long_Unsigned -- + ----------------------------- + + function Scan_Long_Long_Unsigned + (Str : String; + Ptr : access Integer; + Max : Integer) + return Long_Long_Unsigned + is + P : Integer; + -- Local copy of the pointer + + Uval : Long_Long_Unsigned; + -- Accumulated unsigned integer result + + Expon : Integer; + -- Exponent value + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False. Note that + -- a minus sign is permissible for the singular case of -0, and in any + -- case the pointer is left pointing past a negative integer literal. + + Overflow : Boolean := False; + -- Set True if overflow is detected at any point + + Start : Positive; + -- Save location of first non-blank character + + Base_Char : Character; + -- Base character (# or :) in based case + + Base : Long_Long_Unsigned := 10; + -- Base value (reset in based case) + + Digit : Long_Long_Unsigned; + -- Digit value + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + raise Constraint_Error; + end if; + + P := Ptr.all; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); + P := P + 1; + + -- Scan out digits of what is either the number or the base. + -- In either case, we are definitely scanning out in base 10. + + declare + Umax : constant := (Long_Long_Unsigned'Last - 9) / 10; + -- Max value which cannot overflow on accumulating next digit + + Umax10 : constant := Long_Long_Unsigned'Last / 10; + -- Numbers bigger than Umax10 overflow if multiplied by 10 + + begin + -- Loop through decimal digits + loop + exit when P > Max; + + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + -- Non-digit encountered + + if Digit > 9 then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit; + end if; + + -- Accumulate result, checking for overflow + + else + if Uval <= Umax then + Uval := 10 * Uval + Digit; + + elsif Uval > Umax10 then + Overflow := True; + + else + Uval := 10 * Uval + Digit; + + if Uval < Umax10 then + Overflow := True; + end if; + end if; + + P := P + 1; + end if; + end loop; + end; + + Ptr.all := P; + + -- Deal with based case + + if P < Max and then (Str (P) = ':' or else Str (P) = '#') then + Base_Char := Str (P); + P := P + 1; + Base := Uval; + Uval := 0; + + -- Check base value. Overflow is set True if we find a bad base, or + -- a digit that is out of range of the base. That way, we scan out + -- the numeral that is still syntactically correct, though illegal. + -- We use a safe base of 16 for this scan, to avoid zero divide. + + if Base not in 2 .. 16 then + Overflow := True; + Base := 16; + end if; + + -- Scan out based integer + + declare + Umax : constant Long_Long_Unsigned := + (Long_Long_Unsigned'Last - Base + 1) / Base; + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Long_Long_Unsigned := + Long_Long_Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + -- Loop to scan out based integer value + + loop + -- We require a digit at this stage + + if Str (P) in '0' .. '9' then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + -- If we don't have a digit, then this is not a based number + -- after all, so we use the value we scanned out as the base + -- (now in Base), and the pointer to the base character was + -- already stored in Ptr.all. + + else + Uval := Base; + exit; + end if; + + -- If digit is too large, just signal overflow and continue. + -- The idea here is to keep scanning as long as the input is + -- syntactically valid, even if we have detected overflow + + if Digit >= Base then + Overflow := True; + + -- Here we accumulate the value, checking overflow + + elsif Uval <= Umax then + Uval := Base * Uval + Digit; + + elsif Uval > UmaxB then + Overflow := True; + + else + Uval := Base * Uval + Digit; + + if Uval < UmaxB then + Overflow := True; + end if; + end if; + + -- If at end of string with no base char, not a based number + -- but we signal Constraint_Error and set the pointer past + -- the end of the field, since this is what the ACVC tests + -- seem to require, see CE3704N, line 204. + + P := P + 1; + + if P > Max then + Ptr.all := P; + raise Constraint_Error; + end if; + + -- If terminating base character, we are done with loop + + if Str (P) = Base_Char then + Ptr.all := P + 1; + exit; + + -- Deal with underscore + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + end if; + + end loop; + end; + end if; + + -- Come here with scanned unsigned value in Uval. The only remaining + -- required step is to deal with exponent if one is present. + + Expon := Scan_Exponent (Str, Ptr, Max); + + if Expon /= 0 and then Uval /= 0 then + + -- For non-zero value, scale by exponent value. No need to do this + -- efficiently, since use of exponent in integer literals is rare, + -- and in any case the exponent cannot be very large. + + declare + UmaxB : constant Long_Long_Unsigned := + Long_Long_Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + for J in 1 .. Expon loop + if Uval > UmaxB then + Overflow := True; + exit; + end if; + + Uval := Uval * Base; + end loop; + end; + end if; + + -- Return result, dealing with sign and overflow + + if Overflow or else (Minus and then Uval /= 0) then + raise Constraint_Error; + else + return Uval; + end if; + end Scan_Long_Long_Unsigned; + + ------------------------------ + -- Value_Long_Long_Unsigned -- + ------------------------------ + + function Value_Long_Long_Unsigned + (Str : String) + return Long_Long_Unsigned + is + V : Long_Long_Unsigned; + P : aliased Integer := Str'First; + + begin + V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + + end Value_Long_Long_Unsigned; + +end System.Val_LLU; diff --git a/gcc/ada/s-valllu.ads b/gcc/ada/s-valllu.ads new file mode 100644 index 00000000000..897bc36304b --- /dev/null +++ b/gcc/ada/s-valllu.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L U -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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 routines for scanning unsigned Long_Long_Unsigned +-- values for use in Text_IO.Modular_IO, and the Value attribute. + +with System.Unsigned_Types; + +package System.Val_LLU is +pragma Pure (Val_LLU); + + function Scan_Long_Long_Unsigned + (Str : String; + Ptr : access Integer; + Max : Integer) + return System.Unsigned_Types.Long_Long_Unsigned; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. Note that if a minus sign is present, and + -- the integer value is non-zero, then constraint error will be raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Long_Long_Unsigned + (Str : String) + return System.Unsigned_Types.Long_Long_Unsigned; + -- Used in computing X'Value (Str) where X is a modular integer type whose + -- modulus exceeds the range of System.Unsigned_Types.Unsigned. Str is the + -- string argument of the attribute. Constraint_Error is raised if the + -- string is malformed, or if the value is out of range. + +end System.Val_LLU; diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb new file mode 100644 index 00000000000..8ed11d515bc --- /dev/null +++ b/gcc/ada/s-valrea.adb @@ -0,0 +1,336 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ R E A L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.18 $ +-- -- +-- 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 System.Powten_Table; use System.Powten_Table; +with System.Val_Util; use System.Val_Util; + +package body System.Val_Real is + + --------------- + -- Scan_Real -- + --------------- + + function Scan_Real + (Str : String; + Ptr : access Integer; + Max : Integer) + return Long_Long_Float + is + procedure Reset; + pragma Import (C, Reset, "__gnat_init_float"); + -- We import the floating-point processor reset routine so that we can + -- be sure the floating-point processor is properly set for conversion + -- calls (see description of Reset in GNAT.Float_Control (g-flocon.ads). + -- This is notably need on Windows, where calls to the operating system + -- randomly reset the processor into 64-bit mode. + + P : Integer; + -- Local copy of string pointer + + Base : Long_Long_Float; + -- Base value + + Uval : Long_Long_Float; + -- Accumulated float result + + subtype Digs is Character range '0' .. '9'; + -- Used to check for decimal digit + + Scale : Integer := 0; + -- Power of Base to multiply result by + + Start : Positive; + -- Position of starting non-blank character + + Minus : Boolean; + -- Set to True if minus sign is present, otherwise to False + + Bad_Base : Boolean := False; + -- Set True if Base out of range or if out of range digit + + After_Point : Natural := 0; + -- Set to 1 after the point + + procedure Scanf; + -- Scans integer literal value starting at current character position. + -- For each digit encountered, Uval is multiplied by 10.0, and the new + -- digit value is incremented. In addition Scale is decremented for each + -- digit encountered if we are after the point (After_Point = 1). The + -- longest possible syntactically valid numeral is scanned out, and on + -- return P points past the last character. On entry, the current + -- character is known to be a digit, so a numeral is definitely present. + + procedure Scanf is + Digit : Natural; + + begin + loop + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + Uval := Uval * 10.0 + Long_Long_Float (Digit); + P := P + 1; + Scale := Scale - After_Point; + + -- Done if end of input field + + if P > Max then + return; + + -- Check next character + + elsif Str (P) not in Digs then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + return; + end if; + end if; + end loop; + end Scanf; + + -- Start of processing for System.Scan_Real + + begin + Reset; + Scan_Sign (Str, Ptr, Max, Minus, Start); + P := Ptr.all; + Ptr.all := Start; + + -- If digit, scan numeral before point + + if Str (P) in Digs then + Uval := 0.0; + Scanf; + + -- Initial point, allowed only if followed by digit (RM 3.5(47)) + + elsif Str (P) = '.' + and then P < Max + and then Str (P + 1) in Digs + then + Uval := 0.0; + + -- Any other initial character is an error + + else + raise Constraint_Error; + end if; + + -- Deal with based case + + if P < Max and then (Str (P) = ':' or else Str (P) = '#') then + declare + Base_Char : constant Character := Str (P); + Digit : Natural; + Fdigit : Long_Long_Float; + + begin + -- Set bad base if out of range, and use safe base of 16.0, + -- to guard against division by zero in the loop below. + + if Uval < 2.0 or else Uval > 16.0 then + Bad_Base := True; + Uval := 16.0; + end if; + + Base := Uval; + Uval := 0.0; + P := P + 1; + + -- Special check to allow initial point (RM 3.5(49)) + + if Str (P) = '.' then + After_Point := 1; + P := P + 1; + end if; + + -- Loop to scan digits of based number. On entry to the loop we + -- must have a valid digit. If we don't, then we have an illegal + -- floating-point value, and we raise Constraint_Error, note that + -- Ptr at this stage was reset to the proper (Start) value. + + loop + if P > Max then + raise Constraint_Error; + + elsif Str (P) in Digs then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + else + raise Constraint_Error; + end if; + + P := P + 1; + Fdigit := Long_Long_Float (Digit); + + if Fdigit >= Base then + Bad_Base := True; + else + Scale := Scale - After_Point; + Uval := Uval * Base + Fdigit; + end if; + + if P > Max then + raise Constraint_Error; + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + + else + -- Skip past period after digit. Note that the processing + -- here will permit either a digit after the period, or the + -- terminating base character, as allowed in (RM 3.5(48)) + + if Str (P) = '.' and then After_Point = 0 then + P := P + 1; + After_Point := 1; + + if P > Max then + raise Constraint_Error; + end if; + end if; + + exit when Str (P) = Base_Char; + end if; + end loop; + + -- Based number successfully scanned out (point was found) + + Ptr.all := P + 1; + end; + + -- Non-based case, check for being at decimal point now. Note that + -- in Ada 95, we do not insist on a decimal point being present + + else + Base := 10.0; + After_Point := 1; + + if P <= Max and then Str (P) = '.' then + P := P + 1; + + -- Scan digits after point if any are present (RM 3.5(46)) + + if P <= Max and then Str (P) in Digs then + Scanf; + end if; + end if; + + Ptr.all := P; + end if; + + -- At this point, we have Uval containing the digits of the value as + -- an integer, and Scale indicates the negative of the number of digits + -- after the point. Base contains the base value (an integral value in + -- the range 2.0 .. 16.0). Test for exponent, must be at least one + -- character after the E for the exponent to be valid. + + Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True); + + -- At this point the exponent has been scanned if one is present and + -- Scale is adjusted to include the exponent value. Uval contains the + -- the integral value which is to be multiplied by Base ** Scale. + + -- If base is not 10, use exponentiation for scaling + + if Base /= 10.0 then + Uval := Uval * Base ** Scale; + + -- For base 10, use power of ten table, repeatedly if necessary. + + elsif Scale > 0 then + + while Scale > Maxpow loop + Uval := Uval * Powten (Maxpow); + Scale := Scale - Maxpow; + end loop; + + if Scale > 0 then + Uval := Uval * Powten (Scale); + end if; + + elsif Scale < 0 then + + while (-Scale) > Maxpow loop + Uval := Uval / Powten (Maxpow); + Scale := Scale + Maxpow; + end loop; + + if Scale < 0 then + Uval := Uval / Powten (-Scale); + end if; + end if; + + -- Here is where we check for a bad based number + + if Bad_Base then + raise Constraint_Error; + + -- If OK, then deal with initial minus sign, note that this processing + -- is done even if Uval is zero, so that -0.0 is correctly interpreted. + + else + if Minus then + return -Uval; + else + return Uval; + end if; + end if; + + end Scan_Real; + + ---------------- + -- Value_Real -- + ---------------- + + function Value_Real (Str : String) return Long_Long_Float is + V : Long_Long_Float; + P : aliased Integer := Str'First; + + begin + V := Scan_Real (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + + end Value_Real; + +end System.Val_Real; diff --git a/gcc/ada/s-valrea.ads b/gcc/ada/s-valrea.ads new file mode 100644 index 00000000000..8a35e9eb63a --- /dev/null +++ b/gcc/ada/s-valrea.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ R E A L -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +package System.Val_Real is +pragma Pure (Val_Real); + + function Scan_Real + (Str : String; + Ptr : access Integer; + Max : Integer) + return Long_Long_Float; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal according to the syntax described in (RM 3.5(43)). The + -- substring scanned extends no further than Str (Max). There are three + -- cases for the return: + -- + -- If a valid real is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the real (but trailing + -- spaces are not scanned out). + -- + -- If no valid real is found, then Ptr.all points either to an initial + -- non-blank character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid real is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the real literal, + -- and Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the + -- pointer positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Real (Str : String) return Long_Long_Float; + -- Used in computing X'Value (Str) where X is a floating-point type or an + -- ordinary fixed-point type. Str is the string argument of the attribute. + -- Constraint_Error is raised if the string is malformed, or if the value + -- out of range of Long_Long_Float. + +end System.Val_Real; diff --git a/gcc/ada/s-valuns.adb b/gcc/ada/s-valuns.adb new file mode 100644 index 00000000000..f3f552f9502 --- /dev/null +++ b/gcc/ada/s-valuns.adb @@ -0,0 +1,298 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U N S -- +-- -- +-- B o d y -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; + +package body System.Val_Uns is + + ------------------- + -- Scan_Unsigned -- + ------------------- + + function Scan_Unsigned + (Str : String; + Ptr : access Integer; + Max : Integer) + return Unsigned + is + P : Integer; + -- Local copy of the pointer + + Uval : Unsigned; + -- Accumulated unsigned integer result + + Expon : Integer; + -- Exponent value + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False. Note that + -- a minus sign is permissible for the singular case of -0, and in any + -- case the pointer is left pointing past a negative integer literal. + + Overflow : Boolean := False; + -- Set True if overflow is detected at any point + + Start : Positive; + -- Save location of first non-blank character + + Base_Char : Character; + -- Base character (# or :) in based case + + Base : Unsigned := 10; + -- Base value (reset in based case) + + Digit : Unsigned; + -- Digit value + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + raise Constraint_Error; + end if; + + P := Ptr.all; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); + P := P + 1; + + -- Scan out digits of what is either the number or the base. + -- In either case, we are definitely scanning out in base 10. + + declare + Umax : constant := (Unsigned'Last - 9) / 10; + -- Max value which cannot overflow on accumulating next digit + + Umax10 : constant := Unsigned'Last / 10; + -- Numbers bigger than Umax10 overflow if multiplied by 10 + + begin + -- Loop through decimal digits + loop + exit when P > Max; + + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + -- Non-digit encountered + + if Digit > 9 then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit; + end if; + + -- Accumulate result, checking for overflow + + else + if Uval <= Umax then + Uval := 10 * Uval + Digit; + + elsif Uval > Umax10 then + Overflow := True; + + else + Uval := 10 * Uval + Digit; + + if Uval < Umax10 then + Overflow := True; + end if; + end if; + + P := P + 1; + end if; + end loop; + end; + + Ptr.all := P; + + -- Deal with based case + + if P < Max and then (Str (P) = ':' or else Str (P) = '#') then + Base_Char := Str (P); + P := P + 1; + Base := Uval; + Uval := 0; + + -- Check base value. Overflow is set True if we find a bad base, or + -- a digit that is out of range of the base. That way, we scan out + -- the numeral that is still syntactically correct, though illegal. + -- We use a safe base of 16 for this scan, to avoid zero divide. + + if Base not in 2 .. 16 then + Overflow := True; + Base := 16; + end if; + + -- Scan out based integer + + declare + Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base; + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Unsigned := Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + -- Loop to scan out based integer value + + loop + -- We require a digit at this stage + + if Str (P) in '0' .. '9' then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + -- If we don't have a digit, then this is not a based number + -- after all, so we use the value we scanned out as the base + -- (now in Base), and the pointer to the base character was + -- already stored in Ptr.all. + + else + Uval := Base; + exit; + end if; + + -- If digit is too large, just signal overflow and continue. + -- The idea here is to keep scanning as long as the input is + -- syntactically valid, even if we have detected overflow + + if Digit >= Base then + Overflow := True; + + -- Here we accumulate the value, checking overflow + + elsif Uval <= Umax then + Uval := Base * Uval + Digit; + + elsif Uval > UmaxB then + Overflow := True; + + else + Uval := Base * Uval + Digit; + + if Uval < UmaxB then + Overflow := True; + end if; + end if; + + -- If at end of string with no base char, not a based number + -- but we signal Constraint_Error and set the pointer past + -- the end of the field, since this is what the ACVC tests + -- seem to require, see CE3704N, line 204. + + P := P + 1; + + if P > Max then + Ptr.all := P; + raise Constraint_Error; + end if; + + -- If terminating base character, we are done with loop + + if Str (P) = Base_Char then + Ptr.all := P + 1; + exit; + + -- Deal with underscore + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + end if; + + end loop; + end; + end if; + + -- Come here with scanned unsigned value in Uval. The only remaining + -- required step is to deal with exponent if one is present. + + Expon := Scan_Exponent (Str, Ptr, Max); + + if Expon /= 0 and then Uval /= 0 then + + -- For non-zero value, scale by exponent value. No need to do this + -- efficiently, since use of exponent in integer literals is rare, + -- and in any case the exponent cannot be very large. + + declare + UmaxB : constant Unsigned := Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + for J in 1 .. Expon loop + if Uval > UmaxB then + Overflow := True; + exit; + end if; + + Uval := Uval * Base; + end loop; + end; + end if; + + -- Return result, dealing with sign and overflow + + if Overflow or else (Minus and then Uval /= 0) then + raise Constraint_Error; + else + return Uval; + end if; + end Scan_Unsigned; + + -------------------- + -- Value_Unsigned -- + -------------------- + + function Value_Unsigned (Str : String) return Unsigned is + V : Unsigned; + P : aliased Integer := Str'First; + + begin + V := Scan_Unsigned (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + + end Value_Unsigned; + +end System.Val_Uns; diff --git a/gcc/ada/s-valuns.ads b/gcc/ada/s-valuns.ads new file mode 100644 index 00000000000..cc732815f3f --- /dev/null +++ b/gcc/ada/s-valuns.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U N S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.9 $ -- +-- -- +-- 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 routines for scanning modular Unsigned +-- values for use in Text_IO.Modular, and the Value attribute. + +with System.Unsigned_Types; + +package System.Val_Uns is +pragma Pure (Val_Uns); + + function Scan_Unsigned + (Str : String; + Ptr : access Integer; + Max : Integer) + return System.Unsigned_Types.Unsigned; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. Note that if a minus sign is present, and + -- the integer value is non-zero, then constraint error will be raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Unsigned + (Str : String) + return System.Unsigned_Types.Unsigned; + -- Used in computing X'Value (Str) where X is a modular integer type whose + -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str + -- is the string argument of the attribute. Constraint_Error is raised if + -- the string is malformed, or if the value is out of range. + +end System.Val_Uns; diff --git a/gcc/ada/s-valuti.adb b/gcc/ada/s-valuti.adb new file mode 100644 index 00000000000..52eeea956dc --- /dev/null +++ b/gcc/ada/s-valuti.adb @@ -0,0 +1,289 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U T I L -- +-- -- +-- 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 GNAT.Case_Util; use GNAT.Case_Util; + +package body System.Val_Util is + + ---------------------- + -- Normalize_String -- + ---------------------- + + procedure Normalize_String + (S : in out String; + F, L : out Integer) + is + begin + F := S'First; + L := S'Last; + + -- Scan for leading spaces + + while F <= L and then S (F) = ' ' loop + F := F + 1; + end loop; + + -- Check for case when the string contained no characters + + if F > L then + raise Constraint_Error; + end if; + + -- Scan for trailing spaces + + while S (L) = ' ' loop + L := L - 1; + end loop; + + -- Except in the case of a character literal, convert to upper case + + if S (F) /= ''' then + for J in F .. L loop + S (J) := To_Upper (S (J)); + end loop; + end if; + + end Normalize_String; + + ------------------- + -- Scan_Exponent -- + ------------------- + + function Scan_Exponent + (Str : String; + Ptr : access Integer; + Max : Integer; + Real : Boolean := False) + return Integer + is + P : Natural := Ptr.all; + M : Boolean; + X : Integer; + + begin + if P >= Max + or else (Str (P) /= 'E' and then Str (P) /= 'e') + then + return 0; + end if; + + -- We have an E/e, see if sign follows + + P := P + 1; + + if Str (P) = '+' then + P := P + 1; + + if P > Max then + return 0; + else + M := False; + end if; + + elsif Str (P) = '-' then + P := P + 1; + + if P > Max or else not Real then + return 0; + else + M := True; + end if; + + else + M := False; + end if; + + if Str (P) not in '0' .. '9' then + return 0; + end if; + + -- Scan out the exponent value as an unsigned integer. Values larger + -- than (Integer'Last / 10) are simply considered large enough here. + -- This assumption is correct for all machines we know of (e.g. in + -- the case of 16 bit integers it allows exponents up to 3276, which + -- is large enough for the largest floating types in base 2.) + + X := 0; + + loop + if X < (Integer'Last / 10) then + X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); + end if; + + P := P + 1; + + exit when P > Max; + + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit when Str (P) not in '0' .. '9'; + end if; + end loop; + + if M then + X := -X; + end if; + + Ptr.all := P; + return X; + + end Scan_Exponent; + + --------------- + -- Scan_Sign -- + --------------- + + procedure Scan_Sign + (Str : String; + Ptr : access Integer; + Max : Integer; + Minus : out Boolean; + Start : out Positive) + is + P : Natural := Ptr.all; + + begin + -- Deal with case of null string (all blanks!). As per spec, we + -- raise constraint error, with Ptr unchanged, and thus > Max. + + if P > Max then + raise Constraint_Error; + end if; + + -- Scan past initial blanks + + while Str (P) = ' ' loop + P := P + 1; + + if P > Max then + Ptr.all := P; + raise Constraint_Error; + end if; + end loop; + + Start := P; + + -- Remember an initial minus sign + + if Str (P) = '-' then + Minus := True; + P := P + 1; + + if P > Max then + Ptr.all := Start; + raise Constraint_Error; + end if; + + -- Skip past an initial plus sign + + elsif Str (P) = '+' then + Minus := False; + P := P + 1; + + if P > Max then + Ptr.all := Start; + raise Constraint_Error; + end if; + + else + Minus := False; + end if; + + Ptr.all := P; + end Scan_Sign; + + -------------------------- + -- Scan_Trailing_Blanks -- + -------------------------- + + procedure Scan_Trailing_Blanks (Str : String; P : Positive) is + begin + for J in P .. Str'Last loop + if Str (J) /= ' ' then + raise Constraint_Error; + end if; + end loop; + end Scan_Trailing_Blanks; + + --------------------- + -- Scan_Underscore -- + --------------------- + + procedure Scan_Underscore + (Str : String; + P : in out Natural; + Ptr : access Integer; + Max : Integer; + Ext : Boolean) + is + C : Character; + + begin + P := P + 1; + + -- If underscore is at the end of string, then this is an error and + -- we raise Constraint_Error, leaving the pointer past the undescore. + -- This seems a bit strange. It means e,g, that if the field is: + + -- 345_ + + -- that Constraint_Error is raised. You might think that the RM in + -- this case would scan out the 345 as a valid integer, leaving the + -- pointer at the underscore, but the ACVC suite clearly requires + -- an error in this situation (see for example CE3704M). + + if P > Max then + Ptr.all := P; + raise Constraint_Error; + end if; + + -- Similarly, if no digit follows the underscore raise an error. This + -- also catches the case of double underscore which is also an error. + + C := Str (P); + + if C in '0' .. '9' + or else + (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f')) + then + return; + else + Ptr.all := P; + raise Constraint_Error; + end if; + end Scan_Underscore; + +end System.Val_Util; diff --git a/gcc/ada/s-valuti.ads b/gcc/ada/s-valuti.ads new file mode 100644 index 00000000000..23c62253f13 --- /dev/null +++ b/gcc/ada/s-valuti.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- 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 some common utilities used by the s-valxxx files + +package System.Val_Util is +pragma Pure (Val_Util); + + procedure Normalize_String + (S : in out String; + F, L : out Integer); + -- This procedure scans the string S setting F to be the index of the first + -- non-blank character of S and L to be the index of the last non-blank + -- character of S. Any lower case characters present in S will be folded + -- to their upper case equivalent except for character literals. If S + -- consists of entirely blanks then Constraint_Error is raised. + -- + -- Note: if S is the null string, F is set to S'First, L to S'Last + + procedure Scan_Sign + (Str : String; + Ptr : access Integer; + Max : Integer; + Minus : out Boolean; + Start : out Positive); + -- The Str, Ptr, Max parameters are as for the scan routines (Str is the + -- string to be scanned starting at Ptr.all, and Max is the index of the + -- last character in the string). Scan_Sign first scans out any initial + -- blanks, raising Constraint_Error if the field is all blank. It then + -- checks for and skips an initial plus or minus, requiring a non-blank + -- character to follow (Constraint_Error is raised if plus or minus + -- appears at the end of the string or with a following blank). Minus is + -- set True if a minus sign was skipped, and False otherwise. On exit + -- Ptr.all points to the character after the sign, or to the first + -- non-blank character if no sign is present. Start is set to the point + -- to the first non-blank character (sign or digit after it). + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. Constraint_Error is + -- also raised in this case. + + function Scan_Exponent + (Str : String; + Ptr : access Integer; + Max : Integer; + Real : Boolean := False) + return Integer; + -- Called to scan a possible exponent. Str, Ptr, Max are as described above + -- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an + -- exponent is scanned out, with the exponent value returned in Exp, and + -- Ptr.all updated to point past the exponent. If the exponent field is + -- incorrectly formed or not present, then Ptr.all is unchanged, and the + -- returned exponent value is zero. Real indicates whether a minus sign + -- is permitted (True = permitted). Very large exponents are handled by + -- returning a suitable large value. If the base is zero, then any value + -- is allowed, and otherwise the large value will either cause underflow + -- or overflow during the scaling process which is fine. + + procedure Scan_Trailing_Blanks (Str : String; P : Positive); + -- Checks that the remainder of the field Str (P .. Str'Last) is all + -- blanks. Raises Constraint_Error if a non-blank character is found. + + procedure Scan_Underscore + (Str : String; + P : in out Natural; + Ptr : access Integer; + Max : Integer; + Ext : Boolean); + -- Called if an underscore is encountered while scanning digits. Str (P) + -- contains the underscore. Ptr it the pointer to be returned to the + -- ultimate caller of the scan routine, Max is the maximum subscript in + -- Str, and Ext indicates if extended digits are allowed. In the case + -- where the underscore is invalid, Constraint_Error is raised with Ptr + -- set appropriately, otherwise control returns with P incremented past + -- the underscore. + +end System.Val_Util; diff --git a/gcc/ada/s-valwch.adb b/gcc/ada/s-valwch.adb new file mode 100644 index 00000000000..429377faf7b --- /dev/null +++ b/gcc/ada/s-valwch.adb @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.2 $ -- +-- -- +-- 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.Val_Util; use System.Val_Util; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; + +package body System.Val_WChar is + + -------------------------- + -- Value_Wide_Character -- + -------------------------- + + function Value_Wide_Character + (Str : String; + EM : WC_Encoding_Method) + return Wide_Character + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + begin + Normalize_String (S, F, L); + + -- Character literal case + + if S (F) = ''' and then S (L) = ''' then + + -- If just three characters, simple character case + + if L - F = 2 then + return Wide_Character'Val (Character'Pos (S (F + 1))); + + -- Otherwise must be a wide character in quotes. The easiest + -- thing is to convert the string to a wide string and then + -- pick up the single character that it should contain. + + else + declare + WS : constant Wide_String := + String_To_Wide_String (S (F + 1 .. L - 1), EM); + + begin + if WS'Length /= 1 then + raise Constraint_Error; + + else + return WS (WS'First); + end if; + end; + end if; + + -- the last two values of the type have language-defined names: + + elsif S = "FFFE" then + return Wide_Character'Val (16#FFFE#); + + elsif S = "FFFF" then + return Wide_Character'Val (16#FFFF#); + + -- Otherwise must be a control character + + else + for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop + if S (F .. L) = Character'Image (C) then + return Wide_Character'Val (Character'Pos (C)); + end if; + end loop; + + for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop + if S (F .. L) = Character'Image (C) then + return Wide_Character'Val (Character'Pos (C)); + end if; + end loop; + + raise Constraint_Error; + end if; + + end Value_Wide_Character; + +end System.Val_WChar; diff --git a/gcc/ada/s-valwch.ads b/gcc/ada/s-valwch.ads new file mode 100644 index 00000000000..8adb83bf710 --- /dev/null +++ b/gcc/ada/s-valwch.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.2 $ +-- -- +-- 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 System.WCh_Con; + +package System.Val_WChar is +pragma Pure (Val_WChar); + + function Value_Wide_Character + (Str : String; + EM : System.WCh_Con.WC_Encoding_Method) + return Wide_Character; + -- Computes Wide_Character'Value (Str). + +end System.Val_WChar; diff --git a/gcc/ada/s-vercon.adb b/gcc/ada/s-vercon.adb new file mode 100644 index 00000000000..a7d712d4eda --- /dev/null +++ b/gcc/ada/s-vercon.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . V E R S I O N _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +package body System.Version_Control is + + ------------------------ + -- Get_Version_String -- + ------------------------ + + function Get_Version_String + (V : System.Unsigned_Types.Unsigned) + return Version_String + is + S : Version_String; + D : Unsigned := V; + H : array (Unsigned range 0 .. 15) of Character := "0123456789abcdef"; + + begin + for J in reverse 1 .. 8 loop + S (J) := H (D mod 16); + D := D / 16; + end loop; + + return S; + end Get_Version_String; + +end System.Version_Control; diff --git a/gcc/ada/s-vercon.ads b/gcc/ada/s-vercon.ads new file mode 100644 index 00000000000..dceba430451 --- /dev/null +++ b/gcc/ada/s-vercon.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . V E R S I O N _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- 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 module contains the runtime routine for implementation of the +-- Version and Body_Version attributes, as well as the string type that +-- is returned as a result of using these attributes. + +with System.Unsigned_Types; + +package System.Version_Control is + + pragma Pure (Version_Control); + + subtype Version_String is String (1 .. 8); + -- Eight character string returned by Get_version_String; + + function Get_Version_String + (V : System.Unsigned_Types.Unsigned) + return Version_String; + -- The version information in the executable file is stored as unsigned + -- integers. This routine converts the unsigned integer into an eight + -- character string containing its hexadecimal digits (with lower case + -- letters). + +end System.Version_Control; diff --git a/gcc/ada/s-vmexta.adb b/gcc/ada/s-vmexta.adb new file mode 100644 index 00000000000..2be1ae1ada2 --- /dev/null +++ b/gcc/ada/s-vmexta.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.7 $ +-- -- +-- Copyright (C) 1997-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 is an Alpha/VMS package. + +with GNAT.HTable; +pragma Elaborate_All (GNAT.HTable); + +package body System.VMS_Exception_Table is + + use System.Standard_Library; + + type HTable_Headers is range 1 .. 37; + + type Exception_Code_Data; + type Exception_Code_Data_Ptr is access all Exception_Code_Data; + + -- The following record maps an imported VMS condition to an + -- Ada exception. + + type Exception_Code_Data is record + Code : Natural; + Except : Exception_Data_Ptr; + HTable_Ptr : Exception_Code_Data_Ptr; + end record; + + procedure Set_HT_Link + (T : Exception_Code_Data_Ptr; + Next : Exception_Code_Data_Ptr); + + function Get_HT_Link (T : Exception_Code_Data_Ptr) + return Exception_Code_Data_Ptr; + + function Hash (F : Natural) return HTable_Headers; + function Get_Key (T : Exception_Code_Data_Ptr) return Natural; + + package Exception_Code_HTable is new GNAT.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Exception_Code_Data, + Elmt_Ptr => Exception_Code_Data_Ptr, + Null_Ptr => null, + Set_Next => Set_HT_Link, + Next => Get_HT_Link, + Key => Natural, + Get_Key => Get_Key, + Hash => Hash, + Equal => "="); + + --------------------- + -- Coded_Exception -- + --------------------- + + function Coded_Exception (X : Natural) return Exception_Data_Ptr is + Res : Exception_Code_Data_Ptr; + + begin + Res := Exception_Code_HTable.Get (X); + + if Res /= null then + return Res.Except; + else + return null; + end if; + + end Coded_Exception; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Exception_Code_Data_Ptr) + return Exception_Code_Data_Ptr is + begin + return T.HTable_Ptr; + end Get_HT_Link; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (T : Exception_Code_Data_Ptr) return Natural is + begin + return T.Code; + end Get_Key; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Natural) return HTable_Headers is + begin + return HTable_Headers + (F mod Natural (HTable_Headers'Last - HTable_Headers'First + 1) + 1); + end Hash; + + ---------------------------- + -- Register_VMS_Exception -- + ---------------------------- + + procedure Register_VMS_Exception (Code : Integer) is + -- Mask off lower 3 bits which are the severity + + Excode : Integer := (Code / 8) * 8; + begin + + -- This allocates an empty exception that gets filled in by + -- __gnat_error_handler when the exception is raised. Allocating + -- it here prevents having to allocate it each time the exception + -- is raised. + + if Exception_Code_HTable.Get (Excode) = null then + Exception_Code_HTable.Set + (new Exception_Code_Data' + (Excode, + new Exception_Data'(False, 'V', 0, null, null, 0), + null)); + end if; + end Register_VMS_Exception; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link + (T : Exception_Code_Data_Ptr; + Next : Exception_Code_Data_Ptr) + is + begin + T.HTable_Ptr := Next; + end Set_HT_Link; + +end System.VMS_Exception_Table; diff --git a/gcc/ada/s-vmexta.ads b/gcc/ada/s-vmexta.ads new file mode 100644 index 00000000000..4d4b49babdd --- /dev/null +++ b/gcc/ada/s-vmexta.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- Copyright (C) 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 is usually used only on Alpha/VMS systems in the case +-- where there is at least one Import/Export exception present. + +with System.Standard_Library; +package System.VMS_Exception_Table is + + procedure Register_VMS_Exception (Code : Integer); + -- Register an exception in the hash table mapping with a VMS + -- condition code. + + -- LOTS more comments needed here regarding the enire scheme ??? + +private + + function Coded_Exception (X : Natural) + return System.Standard_Library.Exception_Data_Ptr; + -- Given a VMS condition, find and return it's allocated Ada exception + -- (called only from a-init.c). + +end System.VMS_Exception_Table; diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb new file mode 100644 index 00000000000..f15b3440077 --- /dev/null +++ b/gcc/ada/s-wchcnv.adb @@ -0,0 +1,305 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C N V -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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 generic subprograms used for converting between +-- sequences of Character and Wide_Character. All access to wide character +-- sequences is isolated in this unit. + +with Interfaces; use Interfaces; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_JIS; use System.WCh_JIS; + +package body System.WCh_Cnv is + + -------------------------------- + -- Char_Sequence_To_Wide_Char -- + -------------------------------- + + function Char_Sequence_To_Wide_Char + (C : Character; + EM : WC_Encoding_Method) + return Wide_Character + is + B1 : Integer; + C1 : Character; + U : Unsigned_16; + W : Unsigned_16; + + procedure Get_Hex (N : Character); + -- If N is a hex character, then set B1 to 16 * B1 + character N. + -- Raise Constraint_Error if character N is not a hex character. + + ------------- + -- Get_Hex -- + ------------- + + procedure Get_Hex (N : Character) is + B2 : constant Integer := Character'Pos (N); + + begin + if B2 in Character'Pos ('0') .. Character'Pos ('9') then + B1 := B1 * 16 + B2 - Character'Pos ('0'); + + elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then + B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10); + + elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then + B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10); + + else + raise Constraint_Error; + end if; + end Get_Hex; + + -- Start of processing for Char_Sequence_To_Wide_Char + + begin + case EM is + + when WCEM_Hex => + if C /= ASCII.ESC then + return Wide_Character'Val (Character'Pos (C)); + + else + B1 := 0; + Get_Hex (In_Char); + Get_Hex (In_Char); + Get_Hex (In_Char); + Get_Hex (In_Char); + + return Wide_Character'Val (B1); + end if; + + when WCEM_Upper => + if C > ASCII.DEL then + return + Wide_Character'Val + (Integer (256 * Character'Pos (C)) + + Character'Pos (In_Char)); + else + return Wide_Character'Val (Character'Pos (C)); + end if; + + when WCEM_Shift_JIS => + if C > ASCII.DEL then + return Shift_JIS_To_JIS (C, In_Char); + else + return Wide_Character'Val (Character'Pos (C)); + end if; + + when WCEM_EUC => + if C > ASCII.DEL then + return EUC_To_JIS (C, In_Char); + else + return Wide_Character'Val (Character'Pos (C)); + end if; + + when WCEM_UTF8 => + if C > ASCII.DEL then + + -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# + -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# + + U := Unsigned_16 (Character'Pos (C)); + + if (U and 2#11100000#) = 2#11000000# then + W := Shift_Left (U and 2#00011111#, 6); + U := Unsigned_16 (Character'Pos (In_Char)); + + if (U and 2#11000000#) /= 2#10000000# then + raise Constraint_Error; + end if; + + W := W or (U and 2#00111111#); + + elsif (U and 2#11110000#) = 2#11100000# then + W := Shift_Left (U and 2#00001111#, 12); + U := Unsigned_16 (Character'Pos (In_Char)); + + if (U and 2#11000000#) /= 2#10000000# then + raise Constraint_Error; + end if; + + W := W or Shift_Left (U and 2#00111111#, 6); + U := Unsigned_16 (Character'Pos (In_Char)); + + if (U and 2#11000000#) /= 2#10000000# then + raise Constraint_Error; + end if; + + W := W or (U and 2#00111111#); + + else + raise Constraint_Error; + end if; + + return Wide_Character'Val (W); + + else + return Wide_Character'Val (Character'Pos (C)); + end if; + + when WCEM_Brackets => + + if C /= '[' then + return Wide_Character'Val (Character'Pos (C)); + end if; + + if In_Char /= '"' then + raise Constraint_Error; + end if; + + B1 := 0; + Get_Hex (In_Char); + Get_Hex (In_Char); + C1 := In_Char; + + if C1 /= '"' then + Get_Hex (C1); + Get_Hex (In_Char); + C1 := In_Char; + + if C1 /= '"' then + raise Constraint_Error; + end if; + end if; + + if In_Char /= ']' then + raise Constraint_Error; + end if; + + return Wide_Character'Val (B1); + + end case; + end Char_Sequence_To_Wide_Char; + + -------------------------------- + -- Wide_Char_To_Char_Sequence -- + -------------------------------- + + procedure Wide_Char_To_Char_Sequence + (WC : Wide_Character; + EM : WC_Encoding_Method) + is + Val : constant Natural := Wide_Character'Pos (WC); + Hexc : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + C1, C2 : Character; + U : Unsigned_16; + + begin + case EM is + + when WCEM_Hex => + if Val < 256 then + Out_Char (Character'Val (Val)); + + else + Out_Char (ASCII.ESC); + Out_Char (Hexc (Val / (16**3))); + Out_Char (Hexc ((Val / (16**2)) mod 16)); + Out_Char (Hexc ((Val / 16) mod 16)); + Out_Char (Hexc (Val mod 16)); + end if; + + when WCEM_Upper => + if Val < 128 then + Out_Char (Character'Val (Val)); + + elsif Val < 16#8000# then + raise Constraint_Error; + + else + Out_Char (Character'Val (Val / 256)); + Out_Char (Character'Val (Val mod 256)); + end if; + + when WCEM_Shift_JIS => + if Val < 128 then + Out_Char (Character'Val (Val)); + else + JIS_To_Shift_JIS (WC, C1, C2); + Out_Char (C1); + Out_Char (C2); + end if; + + when WCEM_EUC => + if Val < 128 then + Out_Char (Character'Val (Val)); + else + JIS_To_EUC (WC, C1, C2); + Out_Char (C1); + Out_Char (C2); + end if; + + when WCEM_UTF8 => + U := Unsigned_16 (Val); + + -- 16#0000#-16#007f#: 2#0xxxxxxx# + -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# + -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# + + if U < 16#80# then + Out_Char (Character'Val (U)); + + elsif U < 16#0800# then + Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + else + Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + end if; + + when WCEM_Brackets => + + if Val < 256 then + Out_Char (Character'Val (Val)); + + else + Out_Char ('['); + Out_Char ('"'); + Out_Char (Hexc (Val / (16**3))); + Out_Char (Hexc ((Val / (16**2)) mod 16)); + Out_Char (Hexc ((Val / 16) mod 16)); + Out_Char (Hexc (Val mod 16)); + Out_Char ('"'); + Out_Char (']'); + end if; + end case; + end Wide_Char_To_Char_Sequence; + +end System.WCh_Cnv; diff --git a/gcc/ada/s-wchcnv.ads b/gcc/ada/s-wchcnv.ads new file mode 100644 index 00000000000..e42a0645bda --- /dev/null +++ b/gcc/ada/s-wchcnv.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C N V -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ +-- -- +-- 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 contains generic subprograms used for converting between +-- sequences of Character and Wide_Character. All access to wide character +-- sequences is isolated in this unit. + +with System.WCh_Con; + +package System.WCh_Cnv is +pragma Pure (WCh_Cnv); + + generic + with function In_Char return Character; + function Char_Sequence_To_Wide_Char + (C : Character; + EM : System.WCh_Con.WC_Encoding_Method) + return Wide_Character; + -- C is the first character of a sequence of one or more characters which + -- represent a wide character sequence. Calling the function In_Char for + -- additional characters as required, Char_To_Wide_Char returns the + -- corresponding wide character value. Constraint_Error is raised if the + -- sequence of characters encountered is not a valid wide character + -- sequence for the given encoding method. + + generic + with procedure Out_Char (C : Character); + procedure Wide_Char_To_Char_Sequence + (WC : Wide_Character; + EM : System.WCh_Con.WC_Encoding_Method); + -- Given a wide character, converts it into a sequence of one or + -- more characters, calling the given Out_Char procedure for each. + -- Constraint_Error is raised if the given wide character value is + -- not a valid value for the given encoding method. + +end System.WCh_Cnv; diff --git a/gcc/ada/s-wchcon.ads b/gcc/ada/s-wchcon.ads new file mode 100644 index 00000000000..11f6688cbe2 --- /dev/null +++ b/gcc/ada/s-wchcon.ads @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C O N -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- 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 defines the codes used to identify the encoding method for +-- wide characters in string and character constants. This is needed both +-- at compile time and at runtime (for the wide character runtime routines) + +package System.WCh_Con is +pragma Pure (WCh_Con); + + ------------------------------------- + -- Wide_Character Encoding Methods -- + ------------------------------------- + + -- A wide character encoding method is a method for uniquely representing + -- a Wide_Character value using a one or more Character values. Three + -- types of encoding method are supported by GNAT: + + -- An escape encoding method uses ESC as the first character of the + -- sequence, and subsequent characters determine the wide character + -- value that is represented. Any character other than ESC stands + -- for itself as a single byte (i.e. any character in Latin-1, other + -- than ESC itself, is represented as a single character: itself). + + -- An upper half encoding method uses a character in the upper half + -- range (i.e. in the range 16#80# .. 16#FF#) as the first byte of + -- a wide character encoding sequence. Subsequent characters are + -- used to determine the wide character value that is represented. + -- Any character in the lower half (16#00# .. 16#7F#) represents + -- itself as a single character. + + -- The brackets notation, where a wide character is represented + -- by the sequence ["xx"] or ["xxxx"] where xx are hexadecimal + -- characters. + + -- Note that GNAT does not currently support escape-in, escape-out + -- encoding methods, where an escape sequence is used to set a mode + -- used to recognize subsequent characters. All encoding methods use + -- individual character-by-character encodings, so that a sequence of + -- wide characters is represented by a sequence of encodings. + + -- To add new encoding methods, the following steps are required: + + -- 1. Define a code for a new value of type WC_Encoding_Method + -- 2. Adjust the definition of WC_Encoding_Method accordingly + -- 3. Provide appropriate conversion routines in System.Wch_Cnv + -- 4. Adjust definition of WC_Longest_Sequence if necessary + -- 5. Add an entry in WC_Encoding_Letters for the new method + -- 6. Add proper code to s-wchstw.adb, s-wchwts.adb, s-widwch.adb + + -- Note that the WC_Encoding_Method values must be kept ordered so that + -- the definitions of the subtypes WC_Upper_Half_Encoding_Method and + -- WC_ESC_Encoding_Method are still correct. + + --------------------------------- + -- Encoding Method Definitions -- + --------------------------------- + + type WC_Encoding_Method is range 1 .. 6; + -- Type covering the range of values used to represent wide character + -- encoding methods. An enumeration type might be a little neater, but + -- more trouble than it's worth, given the need to pass these values + -- from the compiler to the backend, and to record them in the ALI file. + + WCEM_Hex : constant WC_Encoding_Method := 1; + -- The wide character with code 16#abcd# is represented by the escape + -- sequence ESC a b c d (five characters, where abcd are ASCII hex + -- characters, using upper case for letters). This method is easy + -- to deal with in external environments that do not support wide + -- characters, and covers the whole BMP. This is the default encoding + -- method. + + WCEM_Upper : constant WC_Encoding_Method := 2; + -- The wide character with encoding 16#abcd#, where the upper bit is on + -- (i.e. a is in the range 8-F) is represented as two bytes 16#ab# and + -- 16#cd#. The second byte may never be a format control character, but + -- is not required to be in the upper half. This method can be also used + -- for shift-JIS or EUC where the internal coding matches the external + -- coding. + + WCEM_Shift_JIS : constant WC_Encoding_Method := 3; + -- A wide character is represented by a two character sequence 16#ab# + -- and 16#cd#, with the restrictions described for upper half encoding + -- as described above. The internal character code is the corresponding + -- JIS character according to the standard algorithm for Shift-JIS + -- conversion. See the body of package System.JIS_Conversions for + -- further details. + + WCEM_EUC : constant WC_Encoding_Method := 4; + -- A wide character is represented by a two character sequence 16#ab# and + -- 16#cd#, with both characters being in the upper half set. The internal + -- character code is the corresponding JIS character according to the EUC + -- encoding algorithm. See the body of package System.JIS_Conversions for + -- further details. + + WCEM_UTF8 : constant WC_Encoding_Method := 5; + -- An ISO 10646-1 BMP/Unicode wide character is represented in + -- UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO + -- 10646-1/Am.2. Depending on the character value, a Unicode character + -- is represented as the one, two, or three byte sequence + -- + -- 16#0000#-16#007f#: 2#0xxxxxxx# + -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# + -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# + -- + -- where the xxx bits correspond to the left-padded bits of the the + -- 16-bit character value. Note that all lower half ASCII characters + -- are represented as ASCII bytes and all upper half characters and + -- other wide characters are represented as sequences of upper-half + -- (The full UTF-8 scheme allows for encoding 31-bit characters as + -- 6-byte sequences, but in this implementation, all UTF-8 sequences + -- of four or more bytes length will raise a Constraint_Error, as + -- will all illegal UTF-8 sequences.) + + WCEM_Brackets : constant WC_Encoding_Method := 6; + -- A wide character is represented as the sequence ["abcd"] where abcd + -- are four hexadecimal characters. In this mode, the sequence ["ab"] + -- is also recognized for the case of character codes in the range 0-255. + + WC_Encoding_Letters : constant array (WC_Encoding_Method) of Character := + (WCEM_Hex => 'h', + WCEM_Upper => 'u', + WCEM_Shift_JIS => 's', + WCEM_EUC => 'e', + WCEM_UTF8 => '8', + WCEM_Brackets => 'b'); + -- Letters used for selection of wide character encoding method in the + -- compiler options (-gnatW? switch) and for Wide_Text_IO (WCEM parameter + -- in the form string). + + subtype WC_ESC_Encoding_Method is + WC_Encoding_Method range WCEM_Hex .. WCEM_Hex; + -- Encoding methods using an ESC character at the start of the sequence. + + subtype WC_Upper_Half_Encoding_Method is + WC_Encoding_Method range WCEM_Upper .. WCEM_UTF8; + -- Encoding methods using an upper half character (16#80#..16#FF) at + -- the start of the sequence. + + WC_Longest_Sequence : constant := 8; + -- The longest number of characters that can be used for a wide + -- character sequence for any of the active encoding methods. + +end System.WCh_Con; diff --git a/gcc/ada/s-wchjis.adb b/gcc/ada/s-wchjis.adb new file mode 100644 index 00000000000..e9f9eaad6cd --- /dev/null +++ b/gcc/ada/s-wchjis.adb @@ -0,0 +1,173 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ J I S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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 System.WCh_JIS is + + type Byte is mod 256; + + EUC_Hankaku_Kana : constant Byte := 16#8E#; + -- Prefix byte in EUC for Hankaku Kana (small Katakana). Such characters + -- in EUC are represented by a prefix byte followed by the code, which + -- is in the upper half (the corresponding JIS internal code is in the + -- range 16#0080# - 16#00FF#). + + function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character is + EUC1B : constant Byte := Character'Pos (EUC1); + EUC2B : constant Byte := Character'Pos (EUC2); + + begin + if EUC2B not in 16#A0# .. 16#FE# then + raise Constraint_Error; + end if; + + if EUC1B = EUC_Hankaku_Kana then + return Wide_Character'Val (EUC2B); + + else + if EUC1B not in 16#A0# .. 16#FE# then + raise Constraint_Error; + else + return Wide_Character'Val + (256 * Natural (EUC1B and 16#7F#) + Natural (EUC2B and 16#7F#)); + end if; + end if; + end EUC_To_JIS; + + ---------------- + -- JIS_To_EUC -- + ---------------- + + procedure JIS_To_EUC + (J : in Wide_Character; + EUC1 : out Character; + EUC2 : out Character) + is + JIS1 : constant Natural := Wide_Character'Pos (J) / 256; + JIS2 : constant Natural := Wide_Character'Pos (J) rem 256; + + begin + if JIS1 = 0 then + EUC1 := Character'Val (EUC_Hankaku_Kana); + EUC2 := Character'Val (JIS2); + + else + EUC1 := Character'Val (JIS1 + 16#80#); + EUC2 := Character'Val (JIS2 + 16#80#); + end if; + end JIS_To_EUC; + + ---------------------- + -- JIS_To_Shift_JIS -- + ---------------------- + + procedure JIS_To_Shift_JIS + (J : in Wide_Character; + SJ1 : out Character; + SJ2 : out Character) + is + JIS1 : Byte; + JIS2 : Byte; + + begin + -- The following is the required algorithm, it's hard to make any + -- more intelligent comments! This was copied from a public domain + -- C program called etos.c (author unknown). + + JIS1 := Byte (Natural (Wide_Character'Pos (J) / 256)); + JIS2 := Byte (Natural (Wide_Character'Pos (J) rem 256)); + + if JIS1 > 16#5F# then + JIS1 := JIS1 + 16#80#; + end if; + + if (JIS1 mod 2) = 0 then + SJ1 := Character'Val ((JIS1 - 16#30#) / 2 + 16#88#); + SJ2 := Character'Val (JIS2 + 16#7E#); + + else + if JIS2 >= 16#60# then + JIS2 := JIS2 + 16#01#; + end if; + + SJ1 := Character'Val ((JIS1 - 16#31#) / 2 + 16#89#); + SJ2 := Character'Val (JIS2 + 16#1F#); + end if; + end JIS_To_Shift_JIS; + + ---------------------- + -- Shift_JIS_To_JIS -- + ---------------------- + + function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character is + SJIS1 : Byte; + SJIS2 : Byte; + JIS1 : Byte; + JIS2 : Byte; + + begin + -- The following is the required algorithm, it's hard to make any + -- more intelligent comments! This was copied from a public domain + -- C program called stoj.c written by shige@csk.JUNET. + + SJIS1 := Character'Pos (SJ1); + SJIS2 := Character'Pos (SJ2); + + if SJIS1 >= 16#E0# then + SJIS1 := SJIS1 - 16#40#; + end if; + + if SJIS2 >= 16#9F# then + JIS1 := (SJIS1 - 16#88#) * 2 + 16#30#; + JIS2 := SJIS2 - 16#7E#; + + else + if SJIS2 >= 16#7F# then + SJIS2 := SJIS2 - 16#01#; + end if; + + JIS1 := (SJIS1 - 16#89#) * 2 + 16#31#; + JIS2 := SJIS2 - 16#1F#; + end if; + + if JIS1 not in 16#20# .. 16#7E# + or else JIS2 not in 16#20# .. 16#7E# + then + raise Constraint_Error; + else + return Wide_Character'Val (256 * Natural (JIS1) + Natural (JIS2)); + end if; + end Shift_JIS_To_JIS; + +end System.WCh_JIS; diff --git a/gcc/ada/s-wchjis.ads b/gcc/ada/s-wchjis.ads new file mode 100644 index 00000000000..d226b07d223 --- /dev/null +++ b/gcc/ada/s-wchjis.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ J I S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines used for converting between internal +-- JIS codes and the two external forms we support (EUC and Shift-JIS) + +package System.WCh_JIS is +pragma Pure (WCh_JIS); + + function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character; + -- Given the two bytes of a EUC representation, return the + -- corresponding JIS code wide character. Raises Constraint_Error + -- if the two characters are not a valid EUC encoding. + + procedure JIS_To_EUC + (J : in Wide_Character; + EUC1 : out Character; + EUC2 : out Character); + + -- Given a wide character in JIS form, produce the corresponding + -- two bytes of the EUC representation of this character. This is + -- only used if J is not in the normal ASCII range, i.e. on entry + -- we know that Wide_Character'Pos (J) >= 16#0080# and that we + -- thus require a two byte EUC representation (ASCII codes appear + -- unchanged as a single byte in EUC). No error checking is performed, + -- the input code is assumed to be in an appropriate range. + + procedure JIS_To_Shift_JIS + (J : in Wide_Character; + SJ1 : out Character; + SJ2 : out Character); + -- Given a wide character code in JIS form, produce the corresponding + -- two bytes of the Shift-JIS representation of this character. This + -- is only used if J is not in the normal ASCII range, i.e. on entry + -- we know that Wide_Character'Pos (J) >= 16#0080# and that we + -- thus require a two byte EUC representation (ASCII codes appear + -- unchanged as a single byte in EUC). No error checking is performed, + -- the input code is assumed to be in an appropriate range (note in + -- particular that input codes in the range 16#0080#-16#00FF#, i.e. + -- Hankaku Kana, do not appear, since Shift JIS has no representation + -- for such codes. + + function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character; + -- Given the two bytes of a Shift-JIS representation, return the + -- corresponding JIS code wide character. Raises Constraint_Error if + -- the two characters are not a valid shift-JIS encoding. + +end System.WCh_JIS; diff --git a/gcc/ada/s-wchstw.adb b/gcc/ada/s-wchstw.adb new file mode 100644 index 00000000000..ad9d095e688 --- /dev/null +++ b/gcc/ada/s-wchstw.adb @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ S T W -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- 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; use Interfaces; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_JIS; use System.WCh_JIS; + +package body System.WCh_StW is + + --------------------------- + -- String_To_Wide_String -- + --------------------------- + + function String_To_Wide_String + (S : String; + EM : WC_Encoding_Method) + return Wide_String + is + R : Wide_String (1 .. S'Length); + RP : Natural; + SP : Natural; + U1 : Unsigned_16; + U2 : Unsigned_16; + U3 : Unsigned_16; + U : Unsigned_16; + + Last : constant Natural := S'Last; + + function Get_Hex (C : Character) return Unsigned_16; + -- Converts character from hex digit to value in range 0-15. The + -- input must be in 0-9, A-F, or a-f, and no check is needed. + + procedure Get_Hex_4; + -- Translates four hex characters starting at S (SP) to a single + -- wide character. Used in WCEM_Hex and WCEM_Brackets mode. SP + -- is not modified by the call. The resulting wide character value + -- is stored in R (RP). RP is not modified by the call. + + function Get_Hex (C : Character) return Unsigned_16 is + begin + if C in '0' .. '9' then + return Character'Pos (C) - Character'Pos ('0'); + elsif C in 'A' .. 'F' then + return Character'Pos (C) - Character'Pos ('A') + 10; + else + return Character'Pos (C) - Character'Pos ('a') + 10; + end if; + end Get_Hex; + + procedure Get_Hex_4 is + begin + R (RP) := Wide_Character'Val ( + Get_Hex (S (SP + 3)) + 16 * + (Get_Hex (S (SP + 2)) + 16 * + (Get_Hex (S (SP + 1)) + 16 * + (Get_Hex (S (SP + 0)))))); + end Get_Hex_4; + + -- Start of processing for String_To_Wide_String + + begin + SP := S'First; + RP := 0; + + case EM is + + -- ESC-Hex representation + + when WCEM_Hex => + while SP <= Last - 4 loop + RP := RP + 1; + + if S (SP) = ASCII.ESC then + SP := SP + 1; + Get_Hex_4; + SP := SP + 4; + else + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end if; + end loop; + + -- Upper bit shift, internal code = external code + + when WCEM_Upper => + while SP < Last loop + RP := RP + 1; + + if S (SP) >= Character'Val (16#80#) then + U1 := Character'Pos (S (SP)); + U2 := Character'Pos (S (SP + 1)); + R (RP) := Wide_Character'Val (256 * U1 + U2); + SP := SP + 2; + else + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end if; + end loop; + + -- Upper bit shift, shift-JIS + + when WCEM_Shift_JIS => + while SP < Last loop + RP := RP + 1; + + if S (SP) >= Character'Val (16#80#) then + R (RP) := Shift_JIS_To_JIS (S (SP), S (SP + 1)); + SP := SP + 2; + else + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end if; + end loop; + + -- Upper bit shift, EUC + + when WCEM_EUC => + while SP < Last loop + RP := RP + 1; + + if S (SP) >= Character'Val (16#80#) then + R (RP) := EUC_To_JIS (S (SP), S (SP + 1)); + SP := SP + 2; + else + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end if; + end loop; + + -- Upper bit shift, UTF-8 + + when WCEM_UTF8 => + while SP < Last loop + RP := RP + 1; + + if S (SP) >= Character'Val (16#80#) then + U1 := Character'Pos (S (SP)); + U2 := Character'Pos (S (SP + 1)); + + U := Shift_Left (U1 and 2#00011111#, 6) + + (U2 and 2#00111111#); + SP := SP + 2; + + if U1 >= 2#11100000# then + U3 := Character'Pos (S (SP)); + U := Shift_Left (U, 6) + (U3 and 2#00111111#); + SP := SP + 1; + end if; + + R (RP) := Wide_Character'Val (U); + + else + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end if; + end loop; + + -- Brackets representation + + when WCEM_Brackets => + while SP <= Last - 7 loop + RP := RP + 1; + + if S (SP) = '[' + and then S (SP + 1) = '"' + and then S (SP + 2) /= '"' + then + SP := SP + 2; + Get_Hex_4; + SP := SP + 6; + + else + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end if; + end loop; + + end case; + + while SP <= Last loop + RP := RP + 1; + R (RP) := Wide_Character'Val (Character'Pos (S (SP))); + SP := SP + 1; + end loop; + + return R (1 .. RP); + end String_To_Wide_String; + +end System.WCh_StW; diff --git a/gcc/ada/s-wchstw.ads b/gcc/ada/s-wchstw.ads new file mode 100644 index 00000000000..ee4161d1a1c --- /dev/null +++ b/gcc/ada/s-wchstw.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ S T W -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ -- +-- -- +-- 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 contains the routine used to convert strings to wide +-- strings for use by wide character attributes (value, image etc.) + +with System.WCh_Con; + +package System.WCh_StW is +pragma Pure (WCh_StW); + + function String_To_Wide_String + (S : String; + EM : System.WCh_Con.WC_Encoding_Method) + return Wide_String; + -- This routine simply takes its argument and converts it to wide string + -- format. In the context of the Wide_Image attribute, the argument is + -- the corresponding 'Image attribute. Any wide character escape sequences + -- in the string are converted to the corresponding wide character value. + -- No syntax checks are made, it is assumed that any such sequences are + -- validly formed (this must be assured by the caller), and results from + -- the fact that Wide_Image is only used on strings that have been built + -- by the compiler, such as images of enumeration literals. If the method + -- for encoding is a shift-in, shift-out convention, then it is assumed + -- that normal (non-wide character) mode holds at the start and end of + -- the argument string. EM indicates the wide character encoding method. + -- Note: in the WCEM_Brackets case, the brackets escape sequence is used + -- only for codes greater than 16#FF#. + +end System.WCh_StW; diff --git a/gcc/ada/s-wchwts.adb b/gcc/ada/s-wchwts.adb new file mode 100644 index 00000000000..471c8fdb409 --- /dev/null +++ b/gcc/ada/s-wchwts.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ W T S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.13 $ -- +-- -- +-- 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; use Interfaces; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_JIS; use System.WCh_JIS; + +package body System.WCh_WtS is + + --------------------------- + -- Wide_String_To_String -- + --------------------------- + + function Wide_String_To_String + (S : Wide_String; + EM : WC_Encoding_Method) + return String + is + R : String (1 .. 5 * S'Length); -- worst case length! + RP : Natural; + C1 : Character; + C2 : Character; + + begin + RP := 0; + + for SP in S'Range loop + declare + C : constant Wide_Character := S (SP); + CV : constant Unsigned_16 := Wide_Character'Pos (C); + Hex : constant array (Unsigned_16 range 0 .. 15) of Character := + "0123456789ABCDEF"; + + begin + if CV <= 127 then + RP := RP + 1; + R (RP) := Character'Val (CV); + + else + case EM is + + -- Hex ESC sequence encoding + + when WCEM_Hex => + if CV <= 16#FF# then + RP := RP + 1; + R (RP) := Character'Val (CV); + + else + R (RP + 1) := ASCII.ESC; + R (RP + 2) := Hex (Shift_Right (CV, 12)); + R (RP + 3) := Hex (Shift_Right (CV, 8) and 16#000F#); + R (RP + 4) := Hex (Shift_Right (CV, 4) and 16#000F#); + R (RP + 5) := Hex (CV and 16#000F#); + RP := RP + 5; + end if; + + -- Upper bit shift (internal code = external code) + + when WCEM_Upper => + R (RP + 1) := Character'Val (Shift_Right (CV, 8)); + R (RP + 2) := Character'Val (CV and 16#FF#); + RP := RP + 2; + + -- Upper bit shift (EUC) + + when WCEM_EUC => + JIS_To_EUC (C, C1, C2); + R (RP + 1) := C1; + R (RP + 2) := C2; + RP := RP + 2; + + -- Upper bit shift (Shift-JIS) + + when WCEM_Shift_JIS => + JIS_To_Shift_JIS (C, C1, C2); + R (RP + 1) := C1; + R (RP + 2) := C2; + RP := RP + 2; + + -- Upper bit shift (UTF-8) + + -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx# + -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# + + when WCEM_UTF8 => + if CV < 16#0800# then + R (RP + 1) := + Character'Val (2#11000000# or Shift_Right (CV, 6)); + R (RP + 2) := + Character'Val (2#10000000# or (CV and 2#00111111#)); + RP := RP + 2; + + else + R (RP + 1) := + Character'Val (2#11100000# or Shift_Right (CV, 12)); + R (RP + 2) := + Character'Val (2#10000000# or + (Shift_Right (CV, 6) and + 2#00111111#)); + R (RP + 3) := + Character'Val (2#10000000# or (CV and 2#00111111#)); + RP := RP + 3; + end if; + + -- Brackets encoding + + when WCEM_Brackets => + if CV <= 16#FF# then + RP := RP + 1; + R (RP) := Character'Val (CV); + + else + R (RP + 1) := '['; + R (RP + 2) := '"'; + R (RP + 3) := Hex (Shift_Right (CV, 12)); + R (RP + 4) := Hex (Shift_Right (CV, 8) and 16#000F#); + R (RP + 5) := Hex (Shift_Right (CV, 4) and 16#000F#); + R (RP + 6) := Hex (CV and 16#000F#); + R (RP + 7) := '"'; + R (RP + 8) := ']'; + RP := RP + 8; + end if; + + end case; + end if; + end; + end loop; + + return R (1 .. RP); + end Wide_String_To_String; + +end System.WCh_WtS; diff --git a/gcc/ada/s-wchwts.ads b/gcc/ada/s-wchwts.ads new file mode 100644 index 00000000000..4e5308a7472 --- /dev/null +++ b/gcc/ada/s-wchwts.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ W T S -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.7 $ -- +-- -- +-- 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 contains the routine used to convert wide strings to +-- strings for use by wide character attributes (value, image etc.) and +-- also by the numeric IO subpackages of Ada.Text_IO.Wide_Text_IO. + +with System.WCh_Con; + +package System.WCh_WtS is +pragma Pure (WCh_WtS); + + function Wide_String_To_String + (S : Wide_String; + EM : System.WCh_Con.WC_Encoding_Method) + return String; + -- This routine simply takes its argument and converts it to a string, + -- using the internal compiler escape sequence convention (defined in + -- package Widechar) to translate characters that are out of range + -- of type String. In the context of the Wide_Value attribute, the + -- argument is the original attribute argument, and the result is used + -- in a call to the corresponding Value attribute function. If the method + -- for encoding is a shift-in, shift-out convention, then it is assumed + -- that normal (non-wide character) mode holds at the start and end of + -- the result string. EM indicates the wide character encoding method. + -- Note: in the WCEM_Brackets case, we only use the brackets encoding + -- for characters greater than 16#FF#. + +end System.WCh_WtS; diff --git a/gcc/ada/s-widboo.adb b/gcc/ada/s-widboo.adb new file mode 100644 index 00000000000..5829e998fdd --- /dev/null +++ b/gcc/ada/s-widboo.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ B O O 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 System.Wid_Bool is + + ------------------- + -- Width_Boolean -- + ------------------- + + function Width_Boolean (Lo, Hi : Boolean) return Natural is + begin + if Lo > Hi then + return 0; + + elsif Lo = False then + return 5; + + else + return 4; + end if; + end Width_Boolean; + +end System.Wid_Bool; diff --git a/gcc/ada/s-widboo.ads b/gcc/ada/s-widboo.ads new file mode 100644 index 00000000000..cf283104c14 --- /dev/null +++ b/gcc/ada/s-widboo.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ B O O L -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Boolean'Width + +package System.Wid_Bool is +pragma Pure (Wid_Bool); + + function Width_Boolean (Lo, Hi : Boolean) return Natural; + -- Compute Width attribute for non-static type derived from Boolean. + -- The arguments are the low and high bounds for the type. + +end System.Wid_Bool; diff --git a/gcc/ada/s-widcha.adb b/gcc/ada/s-widcha.adb new file mode 100644 index 00000000000..c2cf6d57c78 --- /dev/null +++ b/gcc/ada/s-widcha.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ C H A R -- +-- -- +-- 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 System.Wid_Char is + + --------------------- + -- Width_Character -- + --------------------- + + function Width_Character (Lo, Hi : Character) return Natural is + W : Natural; + + begin + W := 0; + + for C in Lo .. Hi loop + declare + S : String := Character'Image (C); + + begin + W := Natural'Max (W, S'Length); + end; + end loop; + + return W; + end Width_Character; + +end System.Wid_Char; diff --git a/gcc/ada/s-widcha.ads b/gcc/ada/s-widcha.ads new file mode 100644 index 00000000000..d3b58e74d94 --- /dev/null +++ b/gcc/ada/s-widcha.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Character'Width + +package System.Wid_Char is +pragma Pure (Wid_Char); + + function Width_Character (Lo, Hi : Character) return Natural; + -- Compute Width attribute for non-static type derived from Character. + -- The arguments are the low and high bounds for the type. + +end System.Wid_Char; diff --git a/gcc/ada/s-widenu.adb b/gcc/ada/s-widenu.adb new file mode 100644 index 00000000000..80a255ebf46 --- /dev/null +++ b/gcc/ada/s-widenu.adb @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.9 $ +-- -- +-- 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 Unchecked_Conversion; + +package body System.Wid_Enum is + + ------------------------- + -- Width_Enumeration_8 -- + ------------------------- + + function Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural + is + W : Natural; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); + end loop; + + return W; + end Width_Enumeration_8; + + -------------------------- + -- Width_Enumeration_16 -- + -------------------------- + + function Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural + is + W : Natural; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); + end loop; + + return W; + end Width_Enumeration_16; + + -------------------------- + -- Width_Enumeration_32 -- + -------------------------- + + function Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural + is + W : Natural; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); + end loop; + + return W; + end Width_Enumeration_32; + +end System.Wid_Enum; diff --git a/gcc/ada/s-widenu.ads b/gcc/ada/s-widenu.ads new file mode 100644 index 00000000000..eb48664eebc --- /dev/null +++ b/gcc/ada/s-widenu.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.6 $ +-- -- +-- 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 contains the routine used for Enumeration_Type'Width + +package System.Wid_Enum is +pragma Pure (Wid_Enum); + + function Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural; + -- Used to compute Enum'Width where Enum is some enumeration subtype + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- number of enumeration literals in the type. The Indexes values are + -- the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. + -- + -- Lo and Hi are the Pos values of the lower and upper bounds of the + -- subtype. The result is the value of Width, i.e. the maximum value + -- of the length of any enumeration literal in the given range. + + function Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural; + -- Identical to Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural; + -- Identical to Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + +end System.Wid_Enum; diff --git a/gcc/ada/s-widlli.adb b/gcc/ada/s-widlli.adb new file mode 100644 index 00000000000..6d96260f161 --- /dev/null +++ b/gcc/ada/s-widlli.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L I -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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 System.Wid_LLI is + + ----------------------------- + -- Width_Long_Long_Integer -- + ----------------------------- + + function Width_Long_Long_Integer + (Lo, Hi : Long_Long_Integer) + return Natural + is + W : Natural; + T : Long_Long_Integer; + + begin + if Lo > Hi then + return 0; + + else + -- Minimum value is 2, one for sign, one for digit + + W := 2; + + -- Get max of absolute values, but avoid bomb if we have the maximum + -- negative number (note that First + 1 has same digits as First) + + T := Long_Long_Integer'Max ( + abs (Long_Long_Integer'Max (Lo, Long_Long_Integer'First + 1)), + abs (Long_Long_Integer'Max (Hi, Long_Long_Integer'First + 1))); + + -- Increase value if more digits required + + while T >= 10 loop + T := T / 10; + W := W + 1; + end loop; + + return W; + end if; + + end Width_Long_Long_Integer; + +end System.Wid_LLI; diff --git a/gcc/ada/s-widlli.ads b/gcc/ada/s-widlli.ads new file mode 100644 index 00000000000..37cef827f56 --- /dev/null +++ b/gcc/ada/s-widlli.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L I -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for WIdth attribute for all +-- non-static signed integer subtypes. Note we only have one routine, +-- since this seems a fairly marginal function. + +package System.Wid_LLI is +pragma Pure (Wid_LLI); + + function Width_Long_Long_Integer + (Lo, Hi : Long_Long_Integer) + return Natural; + -- Compute Width attribute for non-static type derived from a signed + -- Integer type. The arguments Lo, Hi are the bounds of the type. + +end System.Wid_LLI; diff --git a/gcc/ada/s-widllu.adb b/gcc/ada/s-widllu.adb new file mode 100644 index 00000000000..6b90031ff82 --- /dev/null +++ b/gcc/ada/s-widllu.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L U -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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.Unsigned_Types; use System.Unsigned_Types; + +package body System.Wid_LLU is + + ------------------------------ + -- Width_Long_Long_Unsigned -- + ------------------------------ + + function Width_Long_Long_Unsigned + (Lo, Hi : Long_Long_Unsigned) + return Natural + is + W : Natural; + T : Long_Long_Unsigned; + + begin + if Lo > Hi then + return 0; + + else + -- Minimum value is 2, one for sign, one for digit + + W := 2; + + -- Get max of absolute values, but avoid bomb if we have the maximum + -- negative number (note that First + 1 has same digits as First) + + T := Long_Long_Unsigned'Max (Lo, Hi); + + -- Increase value if more digits required + + while T >= 10 loop + T := T / 10; + W := W + 1; + end loop; + + return W; + end if; + + end Width_Long_Long_Unsigned; + +end System.Wid_LLU; diff --git a/gcc/ada/s-widllu.ads b/gcc/ada/s-widllu.ads new file mode 100644 index 00000000000..c42a9e2b21b --- /dev/null +++ b/gcc/ada/s-widllu.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L U -- +-- -- +-- S p e c -- +-- -- +-- $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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for WIdth attribute for all +-- non-static unsigned integer (modular integer) subtypes. Note we only +-- have one routine, since this seems a fairly marginal function. + +with System.Unsigned_Types; + +package System.Wid_LLU is +pragma Pure (Wid_LLU); + + function Width_Long_Long_Unsigned + (Lo, Hi : System.Unsigned_Types.Long_Long_Unsigned) + return Natural; + -- Compute Width attribute for non-static type derived from a modular + -- integer type. The arguments Lo, Hi are the bounds of the type. + +end System.Wid_LLU; diff --git a/gcc/ada/s-widwch.adb b/gcc/ada/s-widwch.adb new file mode 100644 index 00000000000..4c6b8ef6a34 --- /dev/null +++ b/gcc/ada/s-widwch.adb @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.10 $ -- +-- -- +-- 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 System.WCh_Con; use System.WCh_Con; + +package body System.Wid_WChar is + + -------------------------- + -- Width_Wide_Character -- + -------------------------- + + function Width_Wide_Character + (Lo, Hi : Wide_Character; + EM : WC_Encoding_Method) + return Natural + is + W : Natural; + P : Natural; + + begin + W := 0; + + for C in Lo .. Hi loop + P := Wide_Character'Pos (C); + + -- Here if we find a character in wide character range + + if P > 16#FF# then + + case EM is + + when WCEM_Hex => + return Natural'Max (W, 5); + + when WCEM_Upper => + return Natural'Max (W, 2); + + when WCEM_Shift_JIS => + return Natural'Max (W, 2); + + when WCEM_EUC => + return Natural'Max (W, 2); + + when WCEM_UTF8 => + if Hi > Wide_Character'Val (16#07FF#) then + return Natural'Max (W, 3); + else + return Natural'Max (W, 2); + end if; + + when WCEM_Brackets => + return Natural'Max (W, 8); + + end case; + + -- If we are in character range then use length of character image + + else + declare + S : constant String := Character'Image (Character'Val (P)); + begin + W := Natural'Max (W, S'Length); + end; + end if; + end loop; + + return W; + end Width_Wide_Character; + +end System.Wid_WChar; diff --git a/gcc/ada/s-widwch.ads b/gcc/ada/s-widwch.ads new file mode 100644 index 00000000000..59847bd4e2f --- /dev/null +++ b/gcc/ada/s-widwch.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.5 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Wide_Character'Width + +with System.WCh_Con; + +package System.Wid_WChar is +pragma Pure (Wid_WChar); + + function Width_Wide_Character + (Lo, Hi : Wide_Character; + EM : System.WCh_Con.WC_Encoding_Method) + return Natural; + -- Compute Width attribute for non-static type derived from Wide_Character. + -- The arguments are the low and high bounds for the type. EM is the + -- wide-character encoding method. + +end System.Wid_WChar; diff --git a/gcc/ada/s-wwdcha.adb b/gcc/ada/s-wwdcha.adb new file mode 100644 index 00000000000..b426d6e482f --- /dev/null +++ b/gcc/ada/s-wwdcha.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- 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 System.WWd_Char is + + -------------------------- + -- Wide_Width_Character -- + -------------------------- + + function Wide_Width_Character (Lo, Hi : Character) return Natural is + W : Natural; + + begin + W := 0; + + for C in Lo .. Hi loop + declare + S : Wide_String := Character'Wide_Image (C); + + begin + W := Natural'Max (W, S'Length); + end; + end loop; + + return W; + end Wide_Width_Character; + +end System.WWd_Char; diff --git a/gcc/ada/s-wwdcha.ads b/gcc/ada/s-wwdcha.ads new file mode 100644 index 00000000000..cb8545d851d --- /dev/null +++ b/gcc/ada/s-wwdcha.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Character'Wide_Width + +package System.WWd_Char is +pragma Pure (WWd_Char); + + function Wide_Width_Character (Lo, Hi : Character) return Natural; + -- Compute Wide_Width attribute for non-static type derived from + -- Character. The arguments are the low and high bounds for the type. + +end System.WWd_Char; diff --git a/gcc/ada/s-wwdenu.adb b/gcc/ada/s-wwdenu.adb new file mode 100644 index 00000000000..8e43b1343eb --- /dev/null +++ b/gcc/ada/s-wwdenu.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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 System.WCh_StW; use System.WCh_StW; +with System.WCh_Con; use System.WCh_Con; + +with Unchecked_Conversion; + +package body System.WWd_Enum is + + ------------------------------ + -- Wide_Width_Enumeration_8 -- + ------------------------------ + + function Wide_Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) + return Natural + is + W : Natural; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + declare + WS : constant Wide_String := + String_To_Wide_String + (Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1), EM); + + begin + W := Natural'Max (W, WS'Length); + end; + end loop; + + return W; + end Wide_Width_Enumeration_8; + + ------------------------------- + -- Wide_Width_Enumeration_16 -- + ------------------------------- + + function Wide_Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) + return Natural + is + W : Natural; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + declare + WS : constant Wide_String := + String_To_Wide_String + (Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1), EM); + + begin + W := Natural'Max (W, WS'Length); + end; + end loop; + + return W; + end Wide_Width_Enumeration_16; + + ------------------------------- + -- Wide_Width_Enumeration_32 -- + ------------------------------- + + function Wide_Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) + return Natural + is + W : Natural; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + declare + WS : constant Wide_String := + String_To_Wide_String + (Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1), EM); + + begin + W := Natural'Max (W, WS'Length); + end; + end loop; + + return W; + end Wide_Width_Enumeration_32; + +end System.WWd_Enum; diff --git a/gcc/ada/s-wwdenu.ads b/gcc/ada/s-wwdenu.ads new file mode 100644 index 00000000000..e8900796788 --- /dev/null +++ b/gcc/ada/s-wwdenu.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.8 $ +-- -- +-- 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 contains the routine used for Enumeration_Type'Wide_Width + +with System.WCh_Con; + +package System.WWd_Enum is +pragma Pure (WWd_Enum); + + function Wide_Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) + return Natural; + -- Used to compute Enum'Wide_Width where Enum is an enumeration subtype + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- number of enumeration literals in the type. The Indexes values are + -- the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. + -- + -- Lo and Hi are the Pos values of the lower and upper bounds of the + -- subtype. The result is the value of Width, i.e. the maximum value + -- of the length of any enumeration literal in the given range. The + -- fifth parameter, EM, is the wide character encoding method used in + -- the Names table. + + function Wide_Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) + return Natural; + -- Identical to Wide_Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Wide_Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) + return Natural; + -- Identical to Wide_Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + +end System.WWd_Enum; diff --git a/gcc/ada/s-wwdwch.adb b/gcc/ada/s-wwdwch.adb new file mode 100644 index 00000000000..216eb6c6575 --- /dev/null +++ b/gcc/ada/s-wwdwch.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ W C H A R -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +package body System.Wwd_WChar is + + ------------------------------- + -- Wide_Width_Wide_Character -- + ------------------------------- + + function Wide_Width_Wide_Character + (Lo, Hi : Wide_Character) + return Natural + is + W : Natural; + P : Natural; + + begin + W := 0; + + for C in Lo .. Hi loop + P := Wide_Character'Pos (C); + + -- If we are in wide character range, the length is always 3 + -- and we are done, since all remaining characters are the same. + + if P > 255 then + return Natural'Max (W, 3); + + -- If we are in character range then use length of character image + -- Is this right, what about wide char encodings of 80-FF??? + + else + declare + S : Wide_String := Character'Wide_Image (Character'Val (P)); + + begin + W := Natural'Max (W, S'Length); + end; + end if; + end loop; + + return W; + end Wide_Width_Wide_Character; + +end System.Wwd_WChar; diff --git a/gcc/ada/s-wwdwch.ads b/gcc/ada/s-wwdwch.ads new file mode 100644 index 00000000000..cf3b93a5597 --- /dev/null +++ b/gcc/ada/s-wwdwch.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- $Revision: 1.3 $ -- +-- -- +-- 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). -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Wide_Character'Wide_Width + +package System.Wwd_WChar is +pragma Pure (Wwd_WChar); + + function Wide_Width_Wide_Character + (Lo, Hi : Wide_Character) + return Natural; + -- Compute Wide_Width attribute for non-static type derived from + -- Wide_Character. The arguments are the low and high bounds for + -- the type. EM is the wide-character encoding method. + +end System.Wwd_WChar; |