------------------------------------------------------------------------------ -- -- -- 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-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. -- -- 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 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 pragma Warnings (Off, 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 Warnings (Off, 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; 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;