diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/i-cobol.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/i-cobol.adb | 994 |
1 files changed, 0 insertions, 994 deletions
diff --git a/gcc-4.4.3/gcc/ada/i-cobol.adb b/gcc-4.4.3/gcc/ada/i-cobol.adb deleted file mode 100644 index ed5b0ab6a..000000000 --- a/gcc-4.4.3/gcc/ada/i-cobol.adb +++ /dev/null @@ -1,994 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . C O B O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- 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 of --- the spec. - -with Interfaces; use Interfaces; -with System; use System; -with Ada.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 Ada.Unchecked_Conversion (Integer_8, B1); - function To_B2 is new Ada.Unchecked_Conversion (Integer_16, B2); - function To_B4 is new Ada.Unchecked_Conversion (Integer_32, B4); - function To_B8 is new Ada.Unchecked_Conversion (Integer_64, B8); - -- Conversions from native binary to external binary - - function From_B1 is new Ada.Unchecked_Conversion (B1, Integer_8); - function From_B2 is new Ada.Unchecked_Conversion (B2, Integer_16); - function From_B4 is new Ada.Unchecked_Conversion (B4, Integer_32); - function From_B8 is new Ada.Unchecked_Conversion (B8, Integer_64); - -- Conversions from external binary to signed native binary - - function From_B1U is new Ada.Unchecked_Conversion (B1, Unsigned_8); - function From_B2U is new Ada.Unchecked_Conversion (B2, Unsigned_16); - function From_B4U is new Ada.Unchecked_Conversion (B4, Unsigned_32); - function From_B8U is new Ada.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)) - - ------------- - -- Convert -- - ------------- - - procedure Convert (First, Last : Natural) is - J : Natural; - - begin - J := Last; - 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; - - ---------------- - -- Embed_Sign -- - ---------------- - - 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. - - ------------- - -- Convert -- - ------------- - - 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 - if Item'Length = 0 then - return False; - end if; - - -- 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 - pragma Unreferenced (Format); - 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 - pragma Unreferenced (Format); - 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; - pragma Unreferenced (Val); - 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; |