diff options
Diffstat (limited to 'gcc/ada/i-cobol.adb')
| -rw-r--r-- | gcc/ada/i-cobol.adb | 1024 |
1 files changed, 1024 insertions, 0 deletions
diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb new file mode 100644 index 00000000000..74b65b9e457 --- /dev/null +++ b/gcc/ada/i-cobol.adb @@ -0,0 +1,1024 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C O B O L -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.14 $ +-- -- +-- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- The body of Interfaces.COBOL is implementation independent (i.e. the +-- same version is used with all versions of GNAT). The specialization +-- to a particular COBOL format is completely contained in the private +-- part ot the spec. + +with Interfaces; use Interfaces; +with System; use System; +with Unchecked_Conversion; + +package body Interfaces.COBOL is + + ----------------------------------------------- + -- Declarations for External Binary Handling -- + ----------------------------------------------- + + subtype B1 is Byte_Array (1 .. 1); + subtype B2 is Byte_Array (1 .. 2); + subtype B4 is Byte_Array (1 .. 4); + subtype B8 is Byte_Array (1 .. 8); + -- Representations for 1,2,4,8 byte binary values + + function To_B1 is new Unchecked_Conversion (Integer_8, B1); + function To_B2 is new Unchecked_Conversion (Integer_16, B2); + function To_B4 is new Unchecked_Conversion (Integer_32, B4); + function To_B8 is new Unchecked_Conversion (Integer_64, B8); + -- Conversions from native binary to external binary + + function From_B1 is new Unchecked_Conversion (B1, Integer_8); + function From_B2 is new Unchecked_Conversion (B2, Integer_16); + function From_B4 is new Unchecked_Conversion (B4, Integer_32); + function From_B8 is new Unchecked_Conversion (B8, Integer_64); + -- Conversions from external binary to signed native binary + + function From_B1U is new Unchecked_Conversion (B1, Unsigned_8); + function From_B2U is new Unchecked_Conversion (B2, Unsigned_16); + function From_B4U is new Unchecked_Conversion (B4, Unsigned_32); + function From_B8U is new Unchecked_Conversion (B8, Unsigned_64); + -- Conversions from external binary to unsigned native binary + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Binary_To_Decimal + (Item : Byte_Array; + Format : Binary_Format) + return Integer_64; + -- This function converts a numeric value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + function Numeric_To_Decimal + (Item : Numeric; + Format : Display_Format) + return Integer_64; + -- This function converts a numeric value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + function Packed_To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Integer_64; + -- This function converts a packed value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + procedure Swap (B : in out Byte_Array; F : Binary_Format); + -- Swaps the bytes if required by the binary format F + + function To_Display + (Item : Integer_64; + Format : Display_Format; + Length : Natural) + return Numeric; + -- This function converts the given integer value into display format, + -- using the given format, with the length in bytes of the result given + -- by the last parameter. This is the non-generic implementation of + -- Decimal_Conversions.To_Display. The conversion of the item from its + -- original decimal format to Integer_64 is done by the generic routine. + + function To_Packed + (Item : Integer_64; + Format : Packed_Format; + Length : Natural) + return Packed_Decimal; + -- This function converts the given integer value into packed format, + -- using the given format, with the length in digits of the result given + -- by the last parameter. This is the non-generic implementation of + -- Decimal_Conversions.To_Display. The conversion of the item from its + -- original decimal format to Integer_64 is done by the generic routine. + + function Valid_Numeric + (Item : Numeric; + Format : Display_Format) + return Boolean; + -- This is the non-generic implementation of Decimal_Conversions.Valid + -- for the display case. + + function Valid_Packed + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean; + -- This is the non-generic implementation of Decimal_Conversions.Valid + -- for the packed case. + + ----------------------- + -- Binary_To_Decimal -- + ----------------------- + + function Binary_To_Decimal + (Item : Byte_Array; + Format : Binary_Format) + return Integer_64 + is + Len : constant Natural := Item'Length; + + begin + if Len = 1 then + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B1U (Item)); + else + return Integer_64 (From_B1 (Item)); + end if; + + elsif Len = 2 then + declare + R : B2 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B2U (R)); + else + return Integer_64 (From_B2 (R)); + end if; + end; + + elsif Len = 4 then + declare + R : B4 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B4U (R)); + else + return Integer_64 (From_B4 (R)); + end if; + end; + + elsif Len = 8 then + declare + R : B8 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B8U (R)); + else + return Integer_64 (From_B8 (R)); + end if; + end; + + -- Length is not 1, 2, 4 or 8 + + else + raise Conversion_Error; + end if; + end Binary_To_Decimal; + + ------------------------ + -- Numeric_To_Decimal -- + ------------------------ + + -- The following assumptions are made in the coding of this routine + + -- The range of COBOL_Digits is compact and the ten values + -- represent the digits 0-9 in sequence + + -- The range of COBOL_Plus_Digits is compact and the ten values + -- represent the digits 0-9 in sequence with a plus sign. + + -- The range of COBOL_Minus_Digits is compact and the ten values + -- represent the digits 0-9 in sequence with a minus sign. + + -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits + + -- These assumptions are true for all COBOL representations we know of. + + function Numeric_To_Decimal + (Item : Numeric; + Format : Display_Format) + return Integer_64 + is + pragma Unsuppress (Range_Check); + Sign : COBOL_Character := COBOL_Plus; + Result : Integer_64 := 0; + + begin + if not Valid_Numeric (Item, Format) then + raise Conversion_Error; + end if; + + for J in Item'Range loop + declare + K : constant COBOL_Character := Item (J); + + begin + if K in COBOL_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Digits'First)); + + elsif K in COBOL_Plus_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Plus_Digits'First)); + + elsif K in COBOL_Minus_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Minus_Digits'First)); + Sign := COBOL_Minus; + + -- Only remaining possibility is COBOL_Plus or COBOL_Minus + + else + Sign := K; + end if; + end; + end loop; + + if Sign = COBOL_Plus then + return Result; + else + return -Result; + end if; + + exception + when Constraint_Error => + raise Conversion_Error; + + end Numeric_To_Decimal; + + ----------------------- + -- Packed_To_Decimal -- + ----------------------- + + function Packed_To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Integer_64 + is + pragma Unsuppress (Range_Check); + Result : Integer_64 := 0; + Sign : constant Decimal_Element := Item (Item'Last); + + begin + if not Valid_Packed (Item, Format) then + raise Conversion_Error; + end if; + + case Packed_Representation is + when IBM => + for J in Item'First .. Item'Last - 1 loop + Result := Result * 10 + Integer_64 (Item (J)); + end loop; + + if Sign = 16#0B# or else Sign = 16#0D# then + return -Result; + else + return +Result; + end if; + end case; + + exception + when Constraint_Error => + raise Conversion_Error; + end Packed_To_Decimal; + + ---------- + -- Swap -- + ---------- + + procedure Swap (B : in out Byte_Array; F : Binary_Format) is + Little_Endian : constant Boolean := + System.Default_Bit_Order = System.Low_Order_First; + + begin + -- Return if no swap needed + + case F is + when H | HU => + if not Little_Endian then + return; + end if; + + when L | LU => + if Little_Endian then + return; + end if; + + when N | NU => + return; + end case; + + -- Here a swap is needed + + declare + Len : constant Natural := B'Length; + + begin + for J in 1 .. Len / 2 loop + declare + Temp : constant Byte := B (J); + + begin + B (J) := B (Len + 1 - J); + B (Len + 1 - J) := Temp; + end; + end loop; + end; + end Swap; + + ----------------------- + -- To_Ada (function) -- + ----------------------- + + function To_Ada (Item : Alphanumeric) return String is + Result : String (Item'Range); + + begin + for J in Item'Range loop + Result (J) := COBOL_To_Ada (Item (J)); + end loop; + + return Result; + end To_Ada; + + ------------------------ + -- To_Ada (procedure) -- + ------------------------ + + procedure To_Ada + (Item : Alphanumeric; + Target : out String; + Last : out Natural) + is + Last_Val : Integer; + + begin + if Item'Length > Target'Length then + raise Constraint_Error; + end if; + + Last_Val := Target'First - 1; + for J in Item'Range loop + Last_Val := Last_Val + 1; + Target (Last_Val) := COBOL_To_Ada (Item (J)); + end loop; + + Last := Last_Val; + end To_Ada; + + ------------------------- + -- To_COBOL (function) -- + ------------------------- + + function To_COBOL (Item : String) return Alphanumeric is + Result : Alphanumeric (Item'Range); + + begin + for J in Item'Range loop + Result (J) := Ada_To_COBOL (Item (J)); + end loop; + + return Result; + end To_COBOL; + + -------------------------- + -- To_COBOL (procedure) -- + -------------------------- + + procedure To_COBOL + (Item : String; + Target : out Alphanumeric; + Last : out Natural) + is + Last_Val : Integer; + + begin + if Item'Length > Target'Length then + raise Constraint_Error; + end if; + + Last_Val := Target'First - 1; + for J in Item'Range loop + Last_Val := Last_Val + 1; + Target (Last_Val) := Ada_To_COBOL (Item (J)); + end loop; + + Last := Last_Val; + end To_COBOL; + + ---------------- + -- To_Display -- + ---------------- + + function To_Display + (Item : Integer_64; + Format : Display_Format; + Length : Natural) + return Numeric + is + Result : Numeric (1 .. Length); + Val : Integer_64 := Item; + + procedure Convert (First, Last : Natural); + -- Convert the number in Val into COBOL_Digits, storing the result + -- in Result (First .. Last). Raise Conversion_Error if too large. + + procedure Embed_Sign (Loc : Natural); + -- Used for the nonseparate formats to embed the appropriate sign + -- at the specified location (i.e. at Result (Loc)) + + procedure Convert (First, Last : Natural) is + J : Natural := Last; + + begin + while J >= First loop + Result (J) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Digits'First) + + Integer (Val mod 10)); + Val := Val / 10; + + if Val = 0 then + for K in First .. J - 1 loop + Result (J) := COBOL_Digits'First; + end loop; + + return; + + else + J := J - 1; + end if; + end loop; + + raise Conversion_Error; + end Convert; + + procedure Embed_Sign (Loc : Natural) is + Digit : Natural range 0 .. 9; + + begin + Digit := COBOL_Character'Pos (Result (Loc)) - + COBOL_Character'Pos (COBOL_Digits'First); + + if Item >= 0 then + Result (Loc) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit); + else + Result (Loc) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit); + end if; + end Embed_Sign; + + -- Start of processing for To_Display + + begin + case Format is + when Unsigned => + if Val < 0 then + raise Conversion_Error; + else + Convert (1, Length); + end if; + + when Leading_Separate => + if Val < 0 then + Result (1) := COBOL_Minus; + Val := -Val; + else + Result (1) := COBOL_Plus; + end if; + + Convert (2, Length); + + when Trailing_Separate => + if Val < 0 then + Result (Length) := COBOL_Minus; + Val := -Val; + else + Result (Length) := COBOL_Plus; + end if; + + Convert (1, Length - 1); + + when Leading_Nonseparate => + Val := abs Val; + Convert (1, Length); + Embed_Sign (1); + + when Trailing_Nonseparate => + Val := abs Val; + Convert (1, Length); + Embed_Sign (Length); + + end case; + + return Result; + end To_Display; + + --------------- + -- To_Packed -- + --------------- + + function To_Packed + (Item : Integer_64; + Format : Packed_Format; + Length : Natural) + return Packed_Decimal + is + Result : Packed_Decimal (1 .. Length); + Val : Integer_64; + + procedure Convert (First, Last : Natural); + -- Convert the number in Val into a sequence of Decimal_Element values, + -- storing the result in Result (First .. Last). Raise Conversion_Error + -- if the value is too large to fit. + + procedure Convert (First, Last : Natural) is + J : Natural := Last; + + begin + while J >= First loop + Result (J) := Decimal_Element (Val mod 10); + + Val := Val / 10; + + if Val = 0 then + for K in First .. J - 1 loop + Result (K) := 0; + end loop; + + return; + + else + J := J - 1; + end if; + end loop; + + raise Conversion_Error; + end Convert; + + -- Start of processing for To_Packed + + begin + case Packed_Representation is + when IBM => + if Format = Packed_Unsigned then + if Item < 0 then + raise Conversion_Error; + else + Result (Length) := 16#F#; + Val := Item; + end if; + + elsif Item >= 0 then + Result (Length) := 16#C#; + Val := Item; + + else -- Item < 0 + Result (Length) := 16#D#; + Val := -Item; + end if; + + Convert (1, Length - 1); + return Result; + end case; + end To_Packed; + + ------------------- + -- Valid_Numeric -- + ------------------- + + function Valid_Numeric + (Item : Numeric; + Format : Display_Format) + return Boolean + is + begin + -- All character positions except first and last must be Digits. + -- This is true for all the formats. + + for J in Item'First + 1 .. Item'Last - 1 loop + if Item (J) not in COBOL_Digits then + return False; + end if; + end loop; + + case Format is + when Unsigned => + return Item (Item'First) in COBOL_Digits + and then Item (Item'Last) in COBOL_Digits; + + when Leading_Separate => + return (Item (Item'First) = COBOL_Plus or else + Item (Item'First) = COBOL_Minus) + and then Item (Item'Last) in COBOL_Digits; + + when Trailing_Separate => + return Item (Item'First) in COBOL_Digits + and then + (Item (Item'Last) = COBOL_Plus or else + Item (Item'Last) = COBOL_Minus); + + when Leading_Nonseparate => + return (Item (Item'First) in COBOL_Plus_Digits or else + Item (Item'First) in COBOL_Minus_Digits) + and then Item (Item'Last) in COBOL_Digits; + + when Trailing_Nonseparate => + return Item (Item'First) in COBOL_Digits + and then + (Item (Item'Last) in COBOL_Plus_Digits or else + Item (Item'Last) in COBOL_Minus_Digits); + + end case; + end Valid_Numeric; + + ------------------ + -- Valid_Packed -- + ------------------ + + function Valid_Packed + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean + is + begin + case Packed_Representation is + when IBM => + for J in Item'First .. Item'Last - 1 loop + if Item (J) > 9 then + return False; + end if; + end loop; + + -- For unsigned, sign digit must be F + + if Format = Packed_Unsigned then + return Item (Item'Last) = 16#F#; + + + -- For signed, accept all standard and non-standard signs + + else + return Item (Item'Last) in 16#A# .. 16#F#; + end if; + end case; + end Valid_Packed; + + ------------------------- + -- Decimal_Conversions -- + ------------------------- + + package body Decimal_Conversions is + + --------------------- + -- Length (binary) -- + --------------------- + + -- Note that the tests here are all compile time tests + + function Length (Format : Binary_Format) return Natural is + begin + if Num'Digits <= 2 then + return 1; + + elsif Num'Digits <= 4 then + return 2; + + elsif Num'Digits <= 9 then + return 4; + + else -- Num'Digits in 10 .. 18 + return 8; + end if; + end Length; + + ---------------------- + -- Length (display) -- + ---------------------- + + function Length (Format : Display_Format) return Natural is + begin + if Format = Leading_Separate or else Format = Trailing_Separate then + return Num'Digits + 1; + else + return Num'Digits; + end if; + end Length; + + --------------------- + -- Length (packed) -- + --------------------- + + -- Note that the tests here are all compile time checks + + function Length + (Format : Packed_Format) + return Natural + is + begin + case Packed_Representation is + when IBM => + return (Num'Digits + 2) / 2 * 2; + end case; + end Length; + + --------------- + -- To_Binary -- + --------------- + + function To_Binary + (Item : Num; + Format : Binary_Format) + return Byte_Array + is + begin + -- Note: all these tests are compile time tests + + if Num'Digits <= 2 then + return To_B1 (Integer_8'Integer_Value (Item)); + + elsif Num'Digits <= 4 then + declare + R : B2 := To_B2 (Integer_16'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + + elsif Num'Digits <= 9 then + declare + R : B4 := To_B4 (Integer_32'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + + else -- Num'Digits in 10 .. 18 + declare + R : B8 := To_B8 (Integer_64'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + end if; + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Binary; + + --------------------------------- + -- To_Binary (internal binary) -- + --------------------------------- + + function To_Binary (Item : Num) return Binary is + pragma Unsuppress (Range_Check); + begin + return Binary'Integer_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Binary; + + ------------------------- + -- To_Decimal (binary) -- + ------------------------- + + function To_Decimal + (Item : Byte_Array; + Format : Binary_Format) + return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ---------------------------------- + -- To_Decimal (internal binary) -- + ---------------------------------- + + function To_Decimal (Item : Binary) return Num is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + -------------------------- + -- To_Decimal (display) -- + -------------------------- + + function To_Decimal + (Item : Numeric; + Format : Display_Format) + return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + --------------------------------------- + -- To_Decimal (internal long binary) -- + --------------------------------------- + + function To_Decimal (Item : Long_Binary) return Num is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ------------------------- + -- To_Decimal (packed) -- + ------------------------- + + function To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) + return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ---------------- + -- To_Display -- + ---------------- + + function To_Display + (Item : Num; + Format : Display_Format) + return Numeric + is + pragma Unsuppress (Range_Check); + + begin + return + To_Display + (Integer_64'Integer_Value (Item), + Format, + Length (Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Display; + + -------------------- + -- To_Long_Binary -- + -------------------- + + function To_Long_Binary (Item : Num) return Long_Binary is + pragma Unsuppress (Range_Check); + + begin + return Long_Binary'Integer_Value (Item); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Long_Binary; + + --------------- + -- To_Packed -- + --------------- + + function To_Packed + (Item : Num; + Format : Packed_Format) + return Packed_Decimal + is + pragma Unsuppress (Range_Check); + + begin + return + To_Packed + (Integer_64'Integer_Value (Item), + Format, + Length (Format)); + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Packed; + + -------------------- + -- Valid (binary) -- + -------------------- + + function Valid + (Item : Byte_Array; + Format : Binary_Format) + return Boolean + is + Val : Num; + + begin + Val := To_Decimal (Item, Format); + return True; + + exception + when Conversion_Error => + return False; + end Valid; + + --------------------- + -- Valid (display) -- + --------------------- + + function Valid + (Item : Numeric; + Format : Display_Format) + return Boolean + is + begin + return Valid_Numeric (Item, Format); + end Valid; + + -------------------- + -- Valid (packed) -- + -------------------- + + function Valid + (Item : Packed_Decimal; + Format : Packed_Format) + return Boolean + is + begin + return Valid_Packed (Item, Format); + end Valid; + + end Decimal_Conversions; + +end Interfaces.COBOL; |