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-2001 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
)
989 Val
:= To_Decimal
(Item
, Format
);
993 when Conversion_Error
=>
997 ---------------------
998 -- Valid (display) --
999 ---------------------
1003 Format
: Display_Format
)
1007 return Valid_Numeric
(Item
, Format
);
1010 --------------------
1011 -- Valid (packed) --
1012 --------------------
1015 (Item
: Packed_Decimal
;
1016 Format
: Packed_Format
)
1020 return Valid_Packed
(Item
, Format
);
1023 end Decimal_Conversions
;
1025 end Interfaces
.COBOL
;