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-2002 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;
112 -- This function converts the given integer value into display format,
113 -- using the given format, with the length in bytes of the result given
114 -- by the last parameter. This is the non-generic implementation of
115 -- Decimal_Conversions.To_Display. The conversion of the item from its
116 -- original decimal format to Integer_64 is done by the generic routine.
120 Format : Packed_Format;
122 return Packed_Decimal;
123 -- This function converts the given integer value into packed format,
124 -- using the given format, with the length in digits of the result given
125 -- by the last parameter. This is the non-generic implementation of
126 -- Decimal_Conversions.To_Display. The conversion of the item from its
127 -- original decimal format to Integer_64 is done by the generic routine.
129 function Valid_Numeric
131 Format : Display_Format)
133 -- This is the non-generic implementation of Decimal_Conversions.Valid
134 -- for the display case.
136 function Valid_Packed
137 (Item : Packed_Decimal;
138 Format : Packed_Format)
140 -- This is the non-generic implementation of Decimal_Conversions.Valid
141 -- for the packed case.
143 -----------------------
144 -- Binary_To_Decimal --
145 -----------------------
147 function Binary_To_Decimal
149 Format : Binary_Format)
152 Len : constant Natural := Item'Length;
156 if Format in Binary_Unsigned_Format then
157 return Integer_64 (From_B1U (Item));
159 return Integer_64 (From_B1 (Item));
169 if Format in Binary_Unsigned_Format then
170 return Integer_64 (From_B2U (R));
172 return Integer_64 (From_B2 (R));
183 if Format in Binary_Unsigned_Format then
184 return Integer_64 (From_B4U (R));
186 return Integer_64 (From_B4 (R));
197 if Format in Binary_Unsigned_Format then
198 return Integer_64 (From_B8U (R));
200 return Integer_64 (From_B8 (R));
204 -- Length is not 1, 2, 4 or 8
207 raise Conversion_Error;
209 end Binary_To_Decimal;
211 ------------------------
212 -- Numeric_To_Decimal --
213 ------------------------
215 -- The following assumptions are made in the coding of this routine
217 -- The range of COBOL_Digits is compact and the ten values
218 -- represent the digits 0-9 in sequence
220 -- The range of COBOL_Plus_Digits is compact and the ten values
221 -- represent the digits 0-9 in sequence with a plus sign.
223 -- The range of COBOL_Minus_Digits is compact and the ten values
224 -- represent the digits 0-9 in sequence with a minus sign.
226 -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits
228 -- These assumptions are true for all COBOL representations we know of.
230 function Numeric_To_Decimal
232 Format : Display_Format)
235 pragma Unsuppress (Range_Check);
236 Sign : COBOL_Character := COBOL_Plus;
237 Result : Integer_64 := 0;
240 if not Valid_Numeric (Item, Format) then
241 raise Conversion_Error;
244 for J in Item'Range loop
246 K : constant COBOL_Character := Item (J);
249 if K in COBOL_Digits then
250 Result := Result * 10 +
251 (COBOL_Character'Pos (K) -
252 COBOL_Character'Pos (COBOL_Digits'First));
254 elsif K in COBOL_Plus_Digits then
255 Result := Result * 10 +
256 (COBOL_Character'Pos (K) -
257 COBOL_Character'Pos (COBOL_Plus_Digits'First));
259 elsif K in COBOL_Minus_Digits then
260 Result := Result * 10 +
261 (COBOL_Character'Pos (K) -
262 COBOL_Character'Pos (COBOL_Minus_Digits'First));
265 -- Only remaining possibility is COBOL_Plus or COBOL_Minus
273 if Sign = COBOL_Plus then
280 when Constraint_Error =>
281 raise Conversion_Error;
283 end Numeric_To_Decimal;
285 -----------------------
286 -- Packed_To_Decimal --
287 -----------------------
289 function Packed_To_Decimal
290 (Item : Packed_Decimal;
291 Format : Packed_Format)
294 pragma Unsuppress (Range_Check);
295 Result : Integer_64 := 0;
296 Sign : constant Decimal_Element := Item (Item'Last);
299 if not Valid_Packed (Item, Format) then
300 raise Conversion_Error;
303 case Packed_Representation is
305 for J in Item'First .. Item'Last - 1 loop
306 Result := Result * 10 + Integer_64 (Item (J));
309 if Sign = 16#0B# or else Sign = 16#0D# then
317 when Constraint_Error =>
318 raise Conversion_Error;
319 end Packed_To_Decimal;
325 procedure Swap (B : in out Byte_Array; F : Binary_Format) is
326 Little_Endian : constant Boolean :=
327 System.Default_Bit_Order = System.Low_Order_First;
330 -- Return if no swap needed
334 if not Little_Endian then
339 if Little_Endian then
347 -- Here a swap is needed
350 Len : constant Natural := B'Length;
353 for J in 1 .. Len / 2 loop
355 Temp : constant Byte := B (J);
358 B (J) := B (Len + 1 - J);
359 B (Len + 1 - J) := Temp;
365 -----------------------
366 -- To_Ada (function) --
367 -----------------------
369 function To_Ada (Item : Alphanumeric) return String is
370 Result : String (Item'Range);
373 for J in Item'Range loop
374 Result (J) := COBOL_To_Ada (Item (J));
380 ------------------------
381 -- To_Ada (procedure) --
382 ------------------------
385 (Item : Alphanumeric;
392 if Item'Length > Target'Length then
393 raise Constraint_Error;
396 Last_Val := Target'First - 1;
397 for J in Item'Range loop
398 Last_Val := Last_Val + 1;
399 Target (Last_Val) := COBOL_To_Ada (Item (J));
405 -------------------------
406 -- To_COBOL (function) --
407 -------------------------
409 function To_COBOL (Item : String) return Alphanumeric is
410 Result : Alphanumeric (Item'Range);
413 for J in Item'Range loop
414 Result (J) := Ada_To_COBOL (Item (J));
420 --------------------------
421 -- To_COBOL (procedure) --
422 --------------------------
426 Target : out Alphanumeric;
432 if Item'Length > Target'Length then
433 raise Constraint_Error;
436 Last_Val := Target'First - 1;
437 for J in Item'Range loop
438 Last_Val := Last_Val + 1;
439 Target (Last_Val) := Ada_To_COBOL (Item (J));
451 Format : Display_Format;
455 Result : Numeric (1 .. Length);
456 Val : Integer_64 := Item;
458 procedure Convert (First, Last : Natural);
459 -- Convert the number in Val into COBOL_Digits, storing the result
460 -- in Result (First .. Last). Raise Conversion_Error if too large.
462 procedure Embed_Sign (Loc : Natural);
463 -- Used for the nonseparate formats to embed the appropriate sign
464 -- at the specified location (i.e. at Result (Loc))
466 procedure Convert (First, Last : Natural) is
470 while J >= First loop
473 (COBOL_Character'Pos (COBOL_Digits'First) +
474 Integer (Val mod 10));
478 for K in First .. J - 1 loop
479 Result (J) := COBOL_Digits'First;
489 raise Conversion_Error;
492 procedure Embed_Sign (Loc : Natural) is
493 Digit : Natural range 0 .. 9;
496 Digit := COBOL_Character'Pos (Result (Loc)) -
497 COBOL_Character'Pos (COBOL_Digits'First);
502 (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit);
506 (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit);
510 -- Start of processing for To_Display
516 raise Conversion_Error;
521 when Leading_Separate =>
523 Result (1) := COBOL_Minus;
526 Result (1) := COBOL_Plus;
531 when Trailing_Separate =>
533 Result (Length) := COBOL_Minus;
536 Result (Length) := COBOL_Plus;
539 Convert (1, Length - 1);
541 when Leading_Nonseparate =>
546 when Trailing_Nonseparate =>
562 Format : Packed_Format;
564 return Packed_Decimal
566 Result : Packed_Decimal (1 .. Length);
569 procedure Convert (First, Last : Natural);
570 -- Convert the number in Val into a sequence of Decimal_Element values,
571 -- storing the result in Result (First .. Last). Raise Conversion_Error
572 -- if the value is too large to fit.
574 procedure Convert (First, Last : Natural) is
578 while J >= First loop
579 Result (J) := Decimal_Element (Val mod 10);
584 for K in First .. J - 1 loop
595 raise Conversion_Error;
598 -- Start of processing for To_Packed
601 case Packed_Representation is
603 if Format = Packed_Unsigned then
605 raise Conversion_Error;
607 Result (Length) := 16#F#;
612 Result (Length) := 16#C#;
616 Result (Length) := 16#D#;
620 Convert (1, Length - 1);
629 function Valid_Numeric
631 Format : Display_Format)
635 -- All character positions except first and last must be Digits.
636 -- This is true for all the formats.
638 for J in Item'First + 1 .. Item'Last - 1 loop
639 if Item (J) not in COBOL_Digits then
646 return Item (Item'First) in COBOL_Digits
647 and then Item (Item'Last) in COBOL_Digits;
649 when Leading_Separate =>
650 return (Item (Item'First) = COBOL_Plus or else
651 Item (Item'First) = COBOL_Minus)
652 and then Item (Item'Last) in COBOL_Digits;
654 when Trailing_Separate =>
655 return Item (Item'First) in COBOL_Digits
657 (Item (Item'Last) = COBOL_Plus or else
658 Item (Item'Last) = COBOL_Minus);
660 when Leading_Nonseparate =>
661 return (Item (Item'First) in COBOL_Plus_Digits or else
662 Item (Item'First) in COBOL_Minus_Digits)
663 and then Item (Item'Last) in COBOL_Digits;
665 when Trailing_Nonseparate =>
666 return Item (Item'First) in COBOL_Digits
668 (Item (Item'Last) in COBOL_Plus_Digits or else
669 Item (Item'Last) in COBOL_Minus_Digits);
678 function Valid_Packed
679 (Item : Packed_Decimal;
680 Format : Packed_Format)
684 case Packed_Representation is
686 for J in Item'First .. Item'Last - 1 loop
692 -- For unsigned, sign digit must be F
694 if Format = Packed_Unsigned then
695 return Item (Item'Last) = 16#F#;
697 -- For signed, accept all standard and non-standard signs
700 return Item (Item'Last) in 16#A# .. 16#F#;
705 -------------------------
706 -- Decimal_Conversions --
707 -------------------------
709 package body Decimal_Conversions is
711 ---------------------
712 -- Length (binary) --
713 ---------------------
715 -- Note that the tests here are all compile time tests
717 function Length (Format : Binary_Format) return Natural is
718 pragma Warnings (Off, Format);
721 if Num'Digits <= 2 then
724 elsif Num'Digits <= 4 then
727 elsif Num'Digits <= 9 then
730 else -- Num'Digits in 10 .. 18
735 ----------------------
736 -- Length (display) --
737 ----------------------
739 function Length (Format : Display_Format) return Natural is
741 if Format = Leading_Separate or else Format = Trailing_Separate then
742 return Num'Digits + 1;
748 ---------------------
749 -- Length (packed) --
750 ---------------------
752 -- Note that the tests here are all compile time checks
755 (Format : Packed_Format)
758 pragma Warnings (Off, Format);
761 case Packed_Representation is
763 return (Num'Digits + 2) / 2 * 2;
773 Format : Binary_Format)
777 -- Note: all these tests are compile time tests
779 if Num'Digits <= 2 then
780 return To_B1 (Integer_8'Integer_Value (Item));
782 elsif Num'Digits <= 4 then
784 R : B2 := To_B2 (Integer_16'Integer_Value (Item));
791 elsif Num'Digits <= 9 then
793 R : B4 := To_B4 (Integer_32'Integer_Value (Item));
800 else -- Num'Digits in 10 .. 18
802 R : B8 := To_B8 (Integer_64'Integer_Value (Item));
811 when Constraint_Error =>
812 raise Conversion_Error;
815 ---------------------------------
816 -- To_Binary (internal binary) --
817 ---------------------------------
819 function To_Binary (Item : Num) return Binary is
820 pragma Unsuppress (Range_Check);
822 return Binary'Integer_Value (Item);
825 when Constraint_Error =>
826 raise Conversion_Error;
829 -------------------------
830 -- To_Decimal (binary) --
831 -------------------------
835 Format : Binary_Format)
838 pragma Unsuppress (Range_Check);
841 return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
844 when Constraint_Error =>
845 raise Conversion_Error;
848 ----------------------------------
849 -- To_Decimal (internal binary) --
850 ----------------------------------
852 function To_Decimal (Item : Binary) return Num is
853 pragma Unsuppress (Range_Check);
856 return Num'Fixed_Value (Item);
859 when Constraint_Error =>
860 raise Conversion_Error;
863 --------------------------
864 -- To_Decimal (display) --
865 --------------------------
869 Format : Display_Format)
872 pragma Unsuppress (Range_Check);
875 return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
878 when Constraint_Error =>
879 raise Conversion_Error;
882 ---------------------------------------
883 -- To_Decimal (internal long binary) --
884 ---------------------------------------
886 function To_Decimal (Item : Long_Binary) return Num is
887 pragma Unsuppress (Range_Check);
890 return Num'Fixed_Value (Item);
893 when Constraint_Error =>
894 raise Conversion_Error;
897 -------------------------
898 -- To_Decimal (packed) --
899 -------------------------
902 (Item : Packed_Decimal;
903 Format : Packed_Format)
906 pragma Unsuppress (Range_Check);
909 return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
912 when Constraint_Error =>
913 raise Conversion_Error;
922 Format : Display_Format)
925 pragma Unsuppress (Range_Check);
930 (Integer_64'Integer_Value (Item),
935 when Constraint_Error =>
936 raise Conversion_Error;
943 function To_Long_Binary (Item : Num) return Long_Binary is
944 pragma Unsuppress (Range_Check);
947 return Long_Binary'Integer_Value (Item);
950 when Constraint_Error =>
951 raise Conversion_Error;
960 Format : Packed_Format)
961 return Packed_Decimal
963 pragma Unsuppress (Range_Check);
968 (Integer_64'Integer_Value (Item),
973 when Constraint_Error =>
974 raise Conversion_Error;
983 Format : Binary_Format)
987 pragma Unreferenced (Val);
990 Val := To_Decimal (Item, Format);
994 when Conversion_Error =>
998 ---------------------
999 -- Valid (display) --
1000 ---------------------
1004 Format : Display_Format)
1008 return Valid_Numeric (Item, Format);
1011 --------------------
1012 -- Valid (packed) --
1013 --------------------
1016 (Item : Packed_Decimal;
1017 Format : Packed_Format)
1021 return Valid_Packed (Item, Format);
1024 end Decimal_Conversions;
1026 end Interfaces.COBOL;