aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/i-cobol.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/i-cobol.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/i-cobol.adb983
1 files changed, 983 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/i-cobol.adb b/gcc-4.3.1/gcc/ada/i-cobol.adb
new file mode 100644
index 000000000..f9f696b9e
--- /dev/null
+++ b/gcc-4.3.1/gcc/ada/i-cobol.adb
@@ -0,0 +1,983 @@
+------------------------------------------------------------------------------
+-- --
+-- 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-2007, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons 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 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))
+
+ 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
+ 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;