1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- I N T E R F A C E S . C O B O L --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- The body of Interfaces.COBOL is implementation independent (i.e. the
35 -- same version is used with all versions of GNAT). The specialization
36 -- to a particular COBOL format is completely contained in the private
39 with Interfaces; use Interfaces;
40 with System; use System;
41 with Unchecked_Conversion;
43 package body Interfaces.COBOL is
45 -----------------------------------------------
46 -- Declarations for External Binary Handling --
47 -----------------------------------------------
49 subtype B1 is Byte_Array (1 .. 1);
50 subtype B2 is Byte_Array (1 .. 2);
51 subtype B4 is Byte_Array (1 .. 4);
52 subtype B8 is Byte_Array (1 .. 8);
53 -- Representations for 1,2,4,8 byte binary values
55 function To_B1 is new Unchecked_Conversion (Integer_8, B1);
56 function To_B2 is new Unchecked_Conversion (Integer_16, B2);
57 function To_B4 is new Unchecked_Conversion (Integer_32, B4);
58 function To_B8 is new Unchecked_Conversion (Integer_64, B8);
59 -- Conversions from native binary to external binary
61 function From_B1 is new Unchecked_Conversion (B1, Integer_8);
62 function From_B2 is new Unchecked_Conversion (B2, Integer_16);
63 function From_B4 is new Unchecked_Conversion (B4, Integer_32);
64 function From_B8 is new Unchecked_Conversion (B8, Integer_64);
65 -- Conversions from external binary to signed native binary
67 function From_B1U is new Unchecked_Conversion (B1, Unsigned_8);
68 function From_B2U is new Unchecked_Conversion (B2, Unsigned_16);
69 function From_B4U is new Unchecked_Conversion (B4, Unsigned_32);
70 function From_B8U is new Unchecked_Conversion (B8, Unsigned_64);
71 -- Conversions from external binary to unsigned native binary
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Binary_To_Decimal
79 Format : Binary_Format)
81 -- This function converts a numeric value in the given format to its
82 -- corresponding integer value. This is the non-generic implementation
83 -- of Decimal_Conversions.To_Decimal. The generic routine does the
84 -- final conversion to the fixed-point format.
86 function Numeric_To_Decimal
88 Format : Display_Format)
90 -- This function converts a numeric value in the given format to its
91 -- corresponding integer value. This is the non-generic implementation
92 -- of Decimal_Conversions.To_Decimal. The generic routine does the
93 -- final conversion to the fixed-point format.
95 function Packed_To_Decimal
96 (Item : Packed_Decimal;
97 Format : Packed_Format)
99 -- This function converts a packed value in the given format to its
100 -- corresponding integer value. This is the non-generic implementation
101 -- of Decimal_Conversions.To_Decimal. The generic routine does the
102 -- final conversion to the fixed-point format.
104 procedure Swap (B : in out Byte_Array; F : Binary_Format);
105 -- Swaps the bytes if required by the binary format F
109 Format : Display_Format;
110 Length : Natural) return Numeric;
111 -- This function converts the given integer value into display format,
112 -- using the given format, with the length in bytes of the result given
113 -- by the last parameter. This is the non-generic implementation of
114 -- Decimal_Conversions.To_Display. The conversion of the item from its
115 -- original decimal format to Integer_64 is done by the generic routine.
119 Format : Packed_Format;
120 Length : Natural) return Packed_Decimal;
121 -- This function converts the given integer value into packed format,
122 -- using the given format, with the length in digits of the result given
123 -- by the last parameter. This is the non-generic implementation of
124 -- Decimal_Conversions.To_Display. The conversion of the item from its
125 -- original decimal format to Integer_64 is done by the generic routine.
127 function Valid_Numeric
129 Format : Display_Format) return Boolean;
130 -- This is the non-generic implementation of Decimal_Conversions.Valid
131 -- for the display case.
133 function Valid_Packed
134 (Item : Packed_Decimal;
135 Format : Packed_Format) return Boolean;
136 -- This is the non-generic implementation of Decimal_Conversions.Valid
137 -- for the packed case.
139 -----------------------
140 -- Binary_To_Decimal --
141 -----------------------
143 function Binary_To_Decimal
145 Format : Binary_Format) return Integer_64
147 Len : constant Natural := Item'Length;
151 if Format in Binary_Unsigned_Format then
152 return Integer_64 (From_B1U (Item));
154 return Integer_64 (From_B1 (Item));
164 if Format in Binary_Unsigned_Format then
165 return Integer_64 (From_B2U (R));
167 return Integer_64 (From_B2 (R));
178 if Format in Binary_Unsigned_Format then
179 return Integer_64 (From_B4U (R));
181 return Integer_64 (From_B4 (R));
192 if Format in Binary_Unsigned_Format then
193 return Integer_64 (From_B8U (R));
195 return Integer_64 (From_B8 (R));
199 -- Length is not 1, 2, 4 or 8
202 raise Conversion_Error;
204 end Binary_To_Decimal;
206 ------------------------
207 -- Numeric_To_Decimal --
208 ------------------------
210 -- The following assumptions are made in the coding of this routine
212 -- The range of COBOL_Digits is compact and the ten values
213 -- represent the digits 0-9 in sequence
215 -- The range of COBOL_Plus_Digits is compact and the ten values
216 -- represent the digits 0-9 in sequence with a plus sign.
218 -- The range of COBOL_Minus_Digits is compact and the ten values
219 -- represent the digits 0-9 in sequence with a minus sign.
221 -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits
223 -- These assumptions are true for all COBOL representations we know of.
225 function Numeric_To_Decimal
227 Format : Display_Format) return Integer_64
229 pragma Unsuppress (Range_Check);
230 Sign : COBOL_Character := COBOL_Plus;
231 Result : Integer_64 := 0;
234 if not Valid_Numeric (Item, Format) then
235 raise Conversion_Error;
238 for J in Item'Range loop
240 K : constant COBOL_Character := Item (J);
243 if K in COBOL_Digits then
244 Result := Result * 10 +
245 (COBOL_Character'Pos (K) -
246 COBOL_Character'Pos (COBOL_Digits'First));
248 elsif K in COBOL_Plus_Digits then
249 Result := Result * 10 +
250 (COBOL_Character'Pos (K) -
251 COBOL_Character'Pos (COBOL_Plus_Digits'First));
253 elsif K in COBOL_Minus_Digits then
254 Result := Result * 10 +
255 (COBOL_Character'Pos (K) -
256 COBOL_Character'Pos (COBOL_Minus_Digits'First));
259 -- Only remaining possibility is COBOL_Plus or COBOL_Minus
267 if Sign = COBOL_Plus then
274 when Constraint_Error =>
275 raise Conversion_Error;
277 end Numeric_To_Decimal;
279 -----------------------
280 -- Packed_To_Decimal --
281 -----------------------
283 function Packed_To_Decimal
284 (Item : Packed_Decimal;
285 Format : Packed_Format) return Integer_64
287 pragma Unsuppress (Range_Check);
288 Result : Integer_64 := 0;
289 Sign : constant Decimal_Element := Item (Item'Last);
292 if not Valid_Packed (Item, Format) then
293 raise Conversion_Error;
296 case Packed_Representation is
298 for J in Item'First .. Item'Last - 1 loop
299 Result := Result * 10 + Integer_64 (Item (J));
302 if Sign = 16#0B# or else Sign = 16#0D# then
310 when Constraint_Error =>
311 raise Conversion_Error;
312 end Packed_To_Decimal;
318 procedure Swap (B : in out Byte_Array; F : Binary_Format) is
319 Little_Endian : constant Boolean :=
320 System.Default_Bit_Order = System.Low_Order_First;
323 -- Return if no swap needed
327 if not Little_Endian then
332 if Little_Endian then
340 -- Here a swap is needed
343 Len : constant Natural := B'Length;
346 for J in 1 .. Len / 2 loop
348 Temp : constant Byte := B (J);
351 B (J) := B (Len + 1 - J);
352 B (Len + 1 - J) := Temp;
358 -----------------------
359 -- To_Ada (function) --
360 -----------------------
362 function To_Ada (Item : Alphanumeric) return String is
363 Result : String (Item'Range);
366 for J in Item'Range loop
367 Result (J) := COBOL_To_Ada (Item (J));
373 ------------------------
374 -- To_Ada (procedure) --
375 ------------------------
378 (Item : Alphanumeric;
385 if Item'Length > Target'Length then
386 raise Constraint_Error;
389 Last_Val := Target'First - 1;
390 for J in Item'Range loop
391 Last_Val := Last_Val + 1;
392 Target (Last_Val) := COBOL_To_Ada (Item (J));
398 -------------------------
399 -- To_COBOL (function) --
400 -------------------------
402 function To_COBOL (Item : String) return Alphanumeric is
403 Result : Alphanumeric (Item'Range);
406 for J in Item'Range loop
407 Result (J) := Ada_To_COBOL (Item (J));
413 --------------------------
414 -- To_COBOL (procedure) --
415 --------------------------
419 Target : out Alphanumeric;
425 if Item'Length > Target'Length then
426 raise Constraint_Error;
429 Last_Val := Target'First - 1;
430 for J in Item'Range loop
431 Last_Val := Last_Val + 1;
432 Target (Last_Val) := Ada_To_COBOL (Item (J));
444 Format : Display_Format;
445 Length : Natural) return Numeric
447 Result : Numeric (1 .. Length);
448 Val : Integer_64 := Item;
450 procedure Convert (First, Last : Natural);
451 -- Convert the number in Val into COBOL_Digits, storing the result
452 -- in Result (First .. Last). Raise Conversion_Error if too large.
454 procedure Embed_Sign (Loc : Natural);
455 -- Used for the nonseparate formats to embed the appropriate sign
456 -- at the specified location (i.e. at Result (Loc))
458 procedure Convert (First, Last : Natural) is
462 while J >= First loop
465 (COBOL_Character'Pos (COBOL_Digits'First) +
466 Integer (Val mod 10));
470 for K in First .. J - 1 loop
471 Result (J) := COBOL_Digits'First;
481 raise Conversion_Error;
484 procedure Embed_Sign (Loc : Natural) is
485 Digit : Natural range 0 .. 9;
488 Digit := COBOL_Character'Pos (Result (Loc)) -
489 COBOL_Character'Pos (COBOL_Digits'First);
494 (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit);
498 (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit);
502 -- Start of processing for To_Display
508 raise Conversion_Error;
513 when Leading_Separate =>
515 Result (1) := COBOL_Minus;
518 Result (1) := COBOL_Plus;
523 when Trailing_Separate =>
525 Result (Length) := COBOL_Minus;
528 Result (Length) := COBOL_Plus;
531 Convert (1, Length - 1);
533 when Leading_Nonseparate =>
538 when Trailing_Nonseparate =>
554 Format : Packed_Format;
555 Length : Natural) return Packed_Decimal
557 Result : Packed_Decimal (1 .. Length);
560 procedure Convert (First, Last : Natural);
561 -- Convert the number in Val into a sequence of Decimal_Element values,
562 -- storing the result in Result (First .. Last). Raise Conversion_Error
563 -- if the value is too large to fit.
565 procedure Convert (First, Last : Natural) is
569 while J >= First loop
570 Result (J) := Decimal_Element (Val mod 10);
575 for K in First .. J - 1 loop
586 raise Conversion_Error;
589 -- Start of processing for To_Packed
592 case Packed_Representation is
594 if Format = Packed_Unsigned then
596 raise Conversion_Error;
598 Result (Length) := 16#F#;
603 Result (Length) := 16#C#;
607 Result (Length) := 16#D#;
611 Convert (1, Length - 1);
620 function Valid_Numeric
622 Format : Display_Format) return Boolean
625 if Item'Length = 0 then
629 -- All character positions except first and last must be Digits.
630 -- This is true for all the formats.
632 for J in Item'First + 1 .. Item'Last - 1 loop
633 if Item (J) not in COBOL_Digits then
640 return Item (Item'First) in COBOL_Digits
641 and then Item (Item'Last) in COBOL_Digits;
643 when Leading_Separate =>
644 return (Item (Item'First) = COBOL_Plus or else
645 Item (Item'First) = COBOL_Minus)
646 and then Item (Item'Last) in COBOL_Digits;
648 when Trailing_Separate =>
649 return Item (Item'First) in COBOL_Digits
651 (Item (Item'Last) = COBOL_Plus or else
652 Item (Item'Last) = COBOL_Minus);
654 when Leading_Nonseparate =>
655 return (Item (Item'First) in COBOL_Plus_Digits or else
656 Item (Item'First) in COBOL_Minus_Digits)
657 and then Item (Item'Last) in COBOL_Digits;
659 when Trailing_Nonseparate =>
660 return Item (Item'First) in COBOL_Digits
662 (Item (Item'Last) in COBOL_Plus_Digits or else
663 Item (Item'Last) in COBOL_Minus_Digits);
672 function Valid_Packed
673 (Item : Packed_Decimal;
674 Format : Packed_Format) return Boolean
677 case Packed_Representation is
679 for J in Item'First .. Item'Last - 1 loop
685 -- For unsigned, sign digit must be F
687 if Format = Packed_Unsigned then
688 return Item (Item'Last) = 16#F#;
690 -- For signed, accept all standard and non-standard signs
693 return Item (Item'Last) in 16#A# .. 16#F#;
698 -------------------------
699 -- Decimal_Conversions --
700 -------------------------
702 package body Decimal_Conversions is
704 ---------------------
705 -- Length (binary) --
706 ---------------------
708 -- Note that the tests here are all compile time tests
710 function Length (Format : Binary_Format) return Natural is
711 pragma Warnings (Off, Format);
713 if Num'Digits <= 2 then
715 elsif Num'Digits <= 4 then
717 elsif Num'Digits <= 9 then
719 else -- Num'Digits in 10 .. 18
724 ----------------------
725 -- Length (display) --
726 ----------------------
728 function Length (Format : Display_Format) return Natural is
730 if Format = Leading_Separate or else Format = Trailing_Separate then
731 return Num'Digits + 1;
737 ---------------------
738 -- Length (packed) --
739 ---------------------
741 -- Note that the tests here are all compile time checks
744 (Format : Packed_Format) return Natural
746 pragma Warnings (Off, Format);
749 case Packed_Representation is
751 return (Num'Digits + 2) / 2 * 2;
761 Format : Binary_Format) return Byte_Array
764 -- Note: all these tests are compile time tests
766 if Num'Digits <= 2 then
767 return To_B1 (Integer_8'Integer_Value (Item));
769 elsif Num'Digits <= 4 then
771 R : B2 := To_B2 (Integer_16'Integer_Value (Item));
778 elsif Num'Digits <= 9 then
780 R : B4 := To_B4 (Integer_32'Integer_Value (Item));
787 else -- Num'Digits in 10 .. 18
789 R : B8 := To_B8 (Integer_64'Integer_Value (Item));
798 when Constraint_Error =>
799 raise Conversion_Error;
802 ---------------------------------
803 -- To_Binary (internal binary) --
804 ---------------------------------
806 function To_Binary (Item : Num) return Binary is
807 pragma Unsuppress (Range_Check);
809 return Binary'Integer_Value (Item);
811 when Constraint_Error =>
812 raise Conversion_Error;
815 -------------------------
816 -- To_Decimal (binary) --
817 -------------------------
821 Format : Binary_Format) return Num
823 pragma Unsuppress (Range_Check);
825 return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
827 when Constraint_Error =>
828 raise Conversion_Error;
831 ----------------------------------
832 -- To_Decimal (internal binary) --
833 ----------------------------------
835 function To_Decimal (Item : Binary) return Num is
836 pragma Unsuppress (Range_Check);
838 return Num'Fixed_Value (Item);
840 when Constraint_Error =>
841 raise Conversion_Error;
844 --------------------------
845 -- To_Decimal (display) --
846 --------------------------
850 Format : Display_Format)
853 pragma Unsuppress (Range_Check);
856 return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
859 when Constraint_Error =>
860 raise Conversion_Error;
863 ---------------------------------------
864 -- To_Decimal (internal long binary) --
865 ---------------------------------------
867 function To_Decimal (Item : Long_Binary) return Num is
868 pragma Unsuppress (Range_Check);
870 return Num'Fixed_Value (Item);
872 when Constraint_Error =>
873 raise Conversion_Error;
876 -------------------------
877 -- To_Decimal (packed) --
878 -------------------------
881 (Item : Packed_Decimal;
882 Format : Packed_Format) return Num
884 pragma Unsuppress (Range_Check);
886 return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
888 when Constraint_Error =>
889 raise Conversion_Error;
898 Format : Display_Format) return Numeric
900 pragma Unsuppress (Range_Check);
904 (Integer_64'Integer_Value (Item),
908 when Constraint_Error =>
909 raise Conversion_Error;
916 function To_Long_Binary (Item : Num) return Long_Binary is
917 pragma Unsuppress (Range_Check);
919 return Long_Binary'Integer_Value (Item);
921 when Constraint_Error =>
922 raise Conversion_Error;
931 Format : Packed_Format) return Packed_Decimal
933 pragma Unsuppress (Range_Check);
937 (Integer_64'Integer_Value (Item),
941 when Constraint_Error =>
942 raise Conversion_Error;
951 Format : Binary_Format) return Boolean
954 pragma Unreferenced (Val);
956 Val := To_Decimal (Item, Format);
959 when Conversion_Error =>
963 ---------------------
964 -- Valid (display) --
965 ---------------------
969 Format : Display_Format) return Boolean
972 return Valid_Numeric (Item, Format);
980 (Item : Packed_Decimal;
981 Format : Packed_Format) return Boolean
984 return Valid_Packed (Item, Format);
987 end Decimal_Conversions;
989 end Interfaces.COBOL;