home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
adav313.zip
/
gnat-3_13p-os2-bin-20010916.zip
/
emx
/
gnatlib
/
i-cobol.adb
< prev
next >
Wrap
Text File
|
2000-07-19
|
29KB
|
1,025 lines
------------------------------------------------------------------------------
-- --
-- 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;
