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-2023, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- The body of Interfaces.COBOL is implementation independent (i.e. the same
33 -- version is used with all versions of GNAT). The specialization to a
34 -- particular COBOL format is completely contained in the private part of
37 with System
; use System
;
38 with Ada
.Unchecked_Conversion
;
40 package body Interfaces
.COBOL
is
42 -----------------------------------------------
43 -- Declarations for External Binary Handling --
44 -----------------------------------------------
46 subtype B1
is Byte_Array
(1 .. 1);
47 subtype B2
is Byte_Array
(1 .. 2);
48 subtype B4
is Byte_Array
(1 .. 4);
49 subtype B8
is Byte_Array
(1 .. 8);
50 -- Representations for 1,2,4,8 byte binary values
52 function To_B1
is new Ada
.Unchecked_Conversion
(Integer_8
, B1
);
53 function To_B2
is new Ada
.Unchecked_Conversion
(Integer_16
, B2
);
54 function To_B4
is new Ada
.Unchecked_Conversion
(Integer_32
, B4
);
55 function To_B8
is new Ada
.Unchecked_Conversion
(Integer_64
, B8
);
56 -- Conversions from native binary to external binary
58 function From_B1
is new Ada
.Unchecked_Conversion
(B1
, Integer_8
);
59 function From_B2
is new Ada
.Unchecked_Conversion
(B2
, Integer_16
);
60 function From_B4
is new Ada
.Unchecked_Conversion
(B4
, Integer_32
);
61 function From_B8
is new Ada
.Unchecked_Conversion
(B8
, Integer_64
);
62 -- Conversions from external binary to signed native binary
64 function From_B1U
is new Ada
.Unchecked_Conversion
(B1
, Unsigned_8
);
65 function From_B2U
is new Ada
.Unchecked_Conversion
(B2
, Unsigned_16
);
66 function From_B4U
is new Ada
.Unchecked_Conversion
(B4
, Unsigned_32
);
67 function From_B8U
is new Ada
.Unchecked_Conversion
(B8
, Unsigned_64
);
68 -- Conversions from external binary to unsigned native binary
70 -----------------------
71 -- Local Subprograms --
72 -----------------------
74 function Binary_To_Decimal
76 Format
: Binary_Format
) return Integer_64
;
77 -- This function converts a numeric value in the given format to its
78 -- corresponding integer value. This is the non-generic implementation
79 -- of Decimal_Conversions.To_Decimal. The generic routine does the
80 -- final conversion to the fixed-point format.
82 function Numeric_To_Decimal
84 Format
: Display_Format
) return Integer_64
;
85 -- This function converts a numeric value in the given format to its
86 -- corresponding integer value. This is the non-generic implementation
87 -- of Decimal_Conversions.To_Decimal. The generic routine does the
88 -- final conversion to the fixed-point format.
90 function Packed_To_Decimal
91 (Item
: Packed_Decimal
;
92 Format
: Packed_Format
) return Integer_64
;
93 -- This function converts a packed value in the given format to its
94 -- corresponding integer value. This is the non-generic implementation
95 -- of Decimal_Conversions.To_Decimal. The generic routine does the
96 -- final conversion to the fixed-point format.
98 procedure Swap
(B
: in out Byte_Array
; F
: Binary_Format
);
99 -- Swaps the bytes if required by the binary format F
103 Format
: Display_Format
;
104 Length
: Natural) return Numeric
;
105 -- This function converts the given integer value into display format,
106 -- using the given format, with the length in bytes of the result given
107 -- by the last parameter. This is the non-generic implementation of
108 -- Decimal_Conversions.To_Display. The conversion of the item from its
109 -- original decimal format to Integer_64 is done by the generic routine.
113 Format
: Packed_Format
;
114 Length
: Natural) return Packed_Decimal
;
115 -- This function converts the given integer value into packed format,
116 -- using the given format, with the length in digits of the result given
117 -- by the last parameter. This is the non-generic implementation of
118 -- Decimal_Conversions.To_Display. The conversion of the item from its
119 -- original decimal format to Integer_64 is done by the generic routine.
121 function Valid_Numeric
123 Format
: Display_Format
) return Boolean;
124 -- This is the non-generic implementation of Decimal_Conversions.Valid
125 -- for the display case.
127 function Valid_Packed
128 (Item
: Packed_Decimal
;
129 Format
: Packed_Format
) return Boolean;
130 -- This is the non-generic implementation of Decimal_Conversions.Valid
131 -- for the packed case.
133 -----------------------
134 -- Binary_To_Decimal --
135 -----------------------
137 function Binary_To_Decimal
139 Format
: Binary_Format
) return Integer_64
141 Len
: constant Natural := Item
'Length;
145 if Format
in Binary_Unsigned_Format
then
146 return Integer_64
(From_B1U
(Item
));
148 return Integer_64
(From_B1
(Item
));
158 if Format
in Binary_Unsigned_Format
then
159 return Integer_64
(From_B2U
(R
));
161 return Integer_64
(From_B2
(R
));
172 if Format
in Binary_Unsigned_Format
then
173 return Integer_64
(From_B4U
(R
));
175 return Integer_64
(From_B4
(R
));
186 if Format
in Binary_Unsigned_Format
then
187 return Integer_64
(From_B8U
(R
));
189 return Integer_64
(From_B8
(R
));
193 -- Length is not 1, 2, 4 or 8
196 raise Conversion_Error
;
198 end Binary_To_Decimal
;
200 ------------------------
201 -- Numeric_To_Decimal --
202 ------------------------
204 -- The following assumptions are made in the coding of this routine:
206 -- The range of COBOL_Digits is compact and the ten values
207 -- represent the digits 0-9 in sequence
209 -- The range of COBOL_Plus_Digits is compact and the ten values
210 -- represent the digits 0-9 in sequence with a plus sign.
212 -- The range of COBOL_Minus_Digits is compact and the ten values
213 -- represent the digits 0-9 in sequence with a minus sign.
215 -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits
217 -- These assumptions are true for all COBOL representations we know of
219 function Numeric_To_Decimal
221 Format
: Display_Format
) return Integer_64
223 pragma Unsuppress
(Range_Check
);
224 Sign
: COBOL_Character
:= COBOL_Plus
;
225 Result
: Integer_64
:= 0;
228 if not Valid_Numeric
(Item
, Format
) then
229 raise Conversion_Error
;
232 for J
in Item
'Range loop
234 K
: constant COBOL_Character
:= Item
(J
);
237 if K
in COBOL_Digits
then
238 Result
:= Result
* 10 +
239 (COBOL_Character
'Pos (K
) -
240 COBOL_Character
'Pos (COBOL_Digits
'First));
242 elsif K
in COBOL_Minus_Digits
then
243 Result
:= Result
* 10 +
244 (COBOL_Character
'Pos (K
) -
245 COBOL_Character
'Pos (COBOL_Minus_Digits
'First));
248 -- Only remaining possibility is COBOL_Plus or COBOL_Minus
256 if Sign
= COBOL_Plus
then
263 when Constraint_Error
=>
264 raise Conversion_Error
;
266 end Numeric_To_Decimal
;
268 -----------------------
269 -- Packed_To_Decimal --
270 -----------------------
272 function Packed_To_Decimal
273 (Item
: Packed_Decimal
;
274 Format
: Packed_Format
) return Integer_64
276 pragma Unsuppress
(Range_Check
);
277 Result
: Integer_64
:= 0;
278 Sign
: constant Decimal_Element
:= Item
(Item
'Last);
281 if not Valid_Packed
(Item
, Format
) then
282 raise Conversion_Error
;
285 case Packed_Representation
is
287 for J
in Item
'First .. Item
'Last - 1 loop
288 Result
:= Result
* 10 + Integer_64
(Item
(J
));
291 if Sign
= 16#
0B#
or else Sign
= 16#
0D#
then
299 when Constraint_Error
=>
300 raise Conversion_Error
;
301 end Packed_To_Decimal
;
307 procedure Swap
(B
: in out Byte_Array
; F
: Binary_Format
) is
308 Little_Endian
: constant Boolean :=
309 System
.Default_Bit_Order
= System
.Low_Order_First
;
312 -- Return if no swap needed
316 if not Little_Endian
then
321 if Little_Endian
then
329 -- Here a swap is needed
332 Len
: constant Natural := B
'Length;
335 for J
in 1 .. Len
/ 2 loop
337 Temp
: constant Byte
:= B
(J
);
340 B
(J
) := B
(Len
+ 1 - J
);
341 B
(Len
+ 1 - J
) := Temp
;
347 -----------------------
348 -- To_Ada (function) --
349 -----------------------
351 function To_Ada
(Item
: Alphanumeric
) return String is
352 Result
: String (Item
'Range);
355 for J
in Item
'Range loop
356 Result
(J
) := COBOL_To_Ada
(Item
(J
));
362 ------------------------
363 -- To_Ada (procedure) --
364 ------------------------
367 (Item
: Alphanumeric
;
374 if Item
'Length > Target
'Length then
375 raise Constraint_Error
;
378 Last_Val
:= Target
'First - 1;
379 for J
in Item
'Range loop
380 Last_Val
:= Last_Val
+ 1;
381 Target
(Last_Val
) := COBOL_To_Ada
(Item
(J
));
387 -------------------------
388 -- To_COBOL (function) --
389 -------------------------
391 function To_COBOL
(Item
: String) return Alphanumeric
is
392 Result
: Alphanumeric
(Item
'Range);
395 for J
in Item
'Range loop
396 Result
(J
) := Ada_To_COBOL
(Item
(J
));
402 --------------------------
403 -- To_COBOL (procedure) --
404 --------------------------
408 Target
: out Alphanumeric
;
414 if Item
'Length > Target
'Length then
415 raise Constraint_Error
;
418 Last_Val
:= Target
'First - 1;
419 for J
in Item
'Range loop
420 Last_Val
:= Last_Val
+ 1;
421 Target
(Last_Val
) := Ada_To_COBOL
(Item
(J
));
433 Format
: Display_Format
;
434 Length
: Natural) return Numeric
436 Result
: Numeric
(1 .. Length
);
437 Val
: Integer_64
:= Item
;
439 procedure Convert
(First
, Last
: Natural);
440 -- Convert the number in Val into COBOL_Digits, storing the result
441 -- in Result (First .. Last). Raise Conversion_Error if too large.
443 procedure Embed_Sign
(Loc
: Natural);
444 -- Used for the nonseparate formats to embed the appropriate sign
445 -- at the specified location (i.e. at Result (Loc))
451 procedure Convert
(First
, Last
: Natural) is
456 while J
>= First
loop
459 (COBOL_Character
'Pos (COBOL_Digits
'First) +
460 Integer (Val
mod 10));
464 for K
in First
.. J
- 1 loop
465 Result
(J
) := COBOL_Digits
'First;
475 raise Conversion_Error
;
482 procedure Embed_Sign
(Loc
: Natural) is
483 Digit
: Natural range 0 .. 9;
486 Digit
:= COBOL_Character
'Pos (Result
(Loc
)) -
487 COBOL_Character
'Pos (COBOL_Digits
'First);
492 (COBOL_Character
'Pos (COBOL_Plus_Digits
'First) + Digit
);
496 (COBOL_Character
'Pos (COBOL_Minus_Digits
'First) + Digit
);
500 -- Start of processing for To_Display
506 raise Conversion_Error
;
511 when Leading_Separate
=>
513 Result
(1) := COBOL_Minus
;
516 Result
(1) := COBOL_Plus
;
521 when Trailing_Separate
=>
523 Result
(Length
) := COBOL_Minus
;
526 Result
(Length
) := COBOL_Plus
;
529 Convert
(1, Length
- 1);
531 when Leading_Nonseparate
=>
536 when Trailing_Nonseparate
=>
551 Format
: Packed_Format
;
552 Length
: Natural) return Packed_Decimal
554 Result
: Packed_Decimal
(1 .. Length
);
557 procedure Convert
(First
, Last
: Natural);
558 -- Convert the number in Val into a sequence of Decimal_Element values,
559 -- storing the result in Result (First .. Last). Raise Conversion_Error
560 -- if the value is too large to fit.
566 procedure Convert
(First
, Last
: Natural) is
570 while J
>= First
loop
571 Result
(J
) := Decimal_Element
(Val
mod 10);
576 for K
in First
.. J
- 1 loop
587 raise Conversion_Error
;
590 -- Start of processing for To_Packed
593 case Packed_Representation
is
595 if Format
= Packed_Unsigned
then
597 raise Conversion_Error
;
599 Result
(Length
) := 16#F#
;
604 Result
(Length
) := 16#C#
;
608 Result
(Length
) := 16#D#
;
612 Convert
(1, Length
- 1);
621 function Valid_Numeric
623 Format
: Display_Format
) return Boolean
626 if Item
'Length = 0 then
630 -- All character positions except first and last must be Digits.
631 -- This is true for all the formats.
633 for J
in Item
'First + 1 .. Item
'Last - 1 loop
634 if Item
(J
) not in COBOL_Digits
then
641 return Item
(Item
'First) in COBOL_Digits
642 and then Item
(Item
'Last) in COBOL_Digits
;
644 when Leading_Separate
=>
645 return (Item
(Item
'First) = COBOL_Plus
or else
646 Item
(Item
'First) = COBOL_Minus
)
647 and then Item
(Item
'Last) in COBOL_Digits
;
649 when Trailing_Separate
=>
650 return Item
(Item
'First) in COBOL_Digits
652 (Item
(Item
'Last) = COBOL_Plus
or else
653 Item
(Item
'Last) = COBOL_Minus
);
655 when Leading_Nonseparate
=>
656 return (Item
(Item
'First) in COBOL_Plus_Digits
or else
657 Item
(Item
'First) in COBOL_Minus_Digits
)
658 and then Item
(Item
'Last) in COBOL_Digits
;
660 when Trailing_Nonseparate
=>
661 return Item
(Item
'First) in COBOL_Digits
663 (Item
(Item
'Last) in COBOL_Plus_Digits
or else
664 Item
(Item
'Last) in COBOL_Minus_Digits
);
673 function Valid_Packed
674 (Item
: Packed_Decimal
;
675 Format
: Packed_Format
) return Boolean
678 case Packed_Representation
is
680 for J
in Item
'First .. Item
'Last - 1 loop
686 -- For unsigned, sign digit must be F
688 if Format
= Packed_Unsigned
then
689 return Item
(Item
'Last) = 16#F#
;
691 -- For signed, accept all standard and non-standard signs
694 return Item
(Item
'Last) >= 16#A#
;
699 -------------------------
700 -- Decimal_Conversions --
701 -------------------------
703 package body Decimal_Conversions
is
705 ---------------------
706 -- Length (binary) --
707 ---------------------
709 -- Note that the tests here are all compile time tests
711 function Length
(Format
: Binary_Format
) return Natural is
712 pragma Unreferenced
(Format
);
714 if Num
'Digits <= 2 then
716 elsif Num
'Digits <= 4 then
718 elsif Num
'Digits <= 9 then
720 else -- Num'Digits in 10 .. 18
725 ----------------------
726 -- Length (display) --
727 ----------------------
729 function Length
(Format
: Display_Format
) return Natural is
731 if Format
= Leading_Separate
or else Format
= Trailing_Separate
then
732 return Num
'Digits + 1;
738 ---------------------
739 -- Length (packed) --
740 ---------------------
742 -- Note that the tests here are all compile time checks
745 (Format
: Packed_Format
) return Natural
747 pragma Unreferenced
(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
) return Num
852 pragma Unsuppress
(Range_Check
);
855 return Num
'Fixed_Value (Numeric_To_Decimal
(Item
, Format
));
857 when Constraint_Error
=>
858 raise Conversion_Error
;
861 ---------------------------------------
862 -- To_Decimal (internal long binary) --
863 ---------------------------------------
865 function To_Decimal
(Item
: Long_Binary
) return Num
is
866 pragma Unsuppress
(Range_Check
);
868 return Num
'Fixed_Value (Item
);
870 when Constraint_Error
=>
871 raise Conversion_Error
;
874 -------------------------
875 -- To_Decimal (packed) --
876 -------------------------
879 (Item
: Packed_Decimal
;
880 Format
: Packed_Format
) return Num
882 pragma Unsuppress
(Range_Check
);
884 return Num
'Fixed_Value (Packed_To_Decimal
(Item
, Format
));
886 when Constraint_Error
=>
887 raise Conversion_Error
;
896 Format
: Display_Format
) return Numeric
898 pragma Unsuppress
(Range_Check
);
902 (Integer_64
'Integer_Value (Item
),
906 when Constraint_Error
=>
907 raise Conversion_Error
;
914 function To_Long_Binary
(Item
: Num
) return Long_Binary
is
915 pragma Unsuppress
(Range_Check
);
917 return Long_Binary
'Integer_Value (Item
);
919 when Constraint_Error
=>
920 raise Conversion_Error
;
929 Format
: Packed_Format
) return Packed_Decimal
931 pragma Unsuppress
(Range_Check
);
935 (Integer_64
'Integer_Value (Item
),
939 when Constraint_Error
=>
940 raise Conversion_Error
;
949 Format
: Binary_Format
) return Boolean
952 pragma Unreferenced
(Val
);
954 Val
:= To_Decimal
(Item
, Format
);
957 when Conversion_Error
=>
961 ---------------------
962 -- Valid (display) --
963 ---------------------
967 Format
: Display_Format
) return Boolean
970 return Valid_Numeric
(Item
, Format
);
978 (Item
: Packed_Decimal
;
979 Format
: Packed_Format
) return Boolean
982 return Valid_Packed
(Item
, Format
);
985 end Decimal_Conversions
;
987 end Interfaces
.COBOL
;