1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- I N T E R F A C E S . C O B O L --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- The body of Interfaces.COBOL is implementation independent (i.e. the
36 -- same version is used with all versions of GNAT). The specialization
37 -- to a particular COBOL format is completely contained in the private
40 with Interfaces
; use Interfaces
;
41 with System
; use System
;
42 with Unchecked_Conversion
;
44 package body Interfaces
.COBOL
is
46 -----------------------------------------------
47 -- Declarations for External Binary Handling --
48 -----------------------------------------------
50 subtype B1
is Byte_Array
(1 .. 1);
51 subtype B2
is Byte_Array
(1 .. 2);
52 subtype B4
is Byte_Array
(1 .. 4);
53 subtype B8
is Byte_Array
(1 .. 8);
54 -- Representations for 1,2,4,8 byte binary values
56 function To_B1
is new Unchecked_Conversion
(Integer_8
, B1
);
57 function To_B2
is new Unchecked_Conversion
(Integer_16
, B2
);
58 function To_B4
is new Unchecked_Conversion
(Integer_32
, B4
);
59 function To_B8
is new Unchecked_Conversion
(Integer_64
, B8
);
60 -- Conversions from native binary to external binary
62 function From_B1
is new Unchecked_Conversion
(B1
, Integer_8
);
63 function From_B2
is new Unchecked_Conversion
(B2
, Integer_16
);
64 function From_B4
is new Unchecked_Conversion
(B4
, Integer_32
);
65 function From_B8
is new Unchecked_Conversion
(B8
, Integer_64
);
66 -- Conversions from external binary to signed native binary
68 function From_B1U
is new Unchecked_Conversion
(B1
, Unsigned_8
);
69 function From_B2U
is new Unchecked_Conversion
(B2
, Unsigned_16
);
70 function From_B4U
is new Unchecked_Conversion
(B4
, Unsigned_32
);
71 function From_B8U
is new Unchecked_Conversion
(B8
, Unsigned_64
);
72 -- Conversions from external binary to unsigned native binary
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Binary_To_Decimal
80 Format
: Binary_Format
)
82 -- This function converts a numeric value in the given format to its
83 -- corresponding integer value. This is the non-generic implementation
84 -- of Decimal_Conversions.To_Decimal. The generic routine does the
85 -- final conversion to the fixed-point format.
87 function Numeric_To_Decimal
89 Format
: Display_Format
)
91 -- This function converts a numeric value in the given format to its
92 -- corresponding integer value. This is the non-generic implementation
93 -- of Decimal_Conversions.To_Decimal. The generic routine does the
94 -- final conversion to the fixed-point format.
96 function Packed_To_Decimal
97 (Item
: Packed_Decimal
;
98 Format
: Packed_Format
)
100 -- This function converts a packed value in the given format to its
101 -- corresponding integer value. This is the non-generic implementation
102 -- of Decimal_Conversions.To_Decimal. The generic routine does the
103 -- final conversion to the fixed-point format.
105 procedure Swap
(B
: in out Byte_Array
; F
: Binary_Format
);
106 -- Swaps the bytes if required by the binary format F
110 Format
: Display_Format
;
113 -- This function converts the given integer value into display format,
114 -- using the given format, with the length in bytes of the result given
115 -- by the last parameter. This is the non-generic implementation of
116 -- Decimal_Conversions.To_Display. The conversion of the item from its
117 -- original decimal format to Integer_64 is done by the generic routine.
121 Format
: Packed_Format
;
123 return Packed_Decimal
;
124 -- This function converts the given integer value into packed format,
125 -- using the given format, with the length in digits of the result given
126 -- by the last parameter. This is the non-generic implementation of
127 -- Decimal_Conversions.To_Display. The conversion of the item from its
128 -- original decimal format to Integer_64 is done by the generic routine.
130 function Valid_Numeric
132 Format
: Display_Format
)
134 -- This is the non-generic implementation of Decimal_Conversions.Valid
135 -- for the display case.
137 function Valid_Packed
138 (Item
: Packed_Decimal
;
139 Format
: Packed_Format
)
141 -- This is the non-generic implementation of Decimal_Conversions.Valid
142 -- for the packed case.
144 -----------------------
145 -- Binary_To_Decimal --
146 -----------------------
148 function Binary_To_Decimal
150 Format
: Binary_Format
)
153 Len
: constant Natural := Item
'Length;
157 if Format
in Binary_Unsigned_Format
then
158 return Integer_64
(From_B1U
(Item
));
160 return Integer_64
(From_B1
(Item
));
170 if Format
in Binary_Unsigned_Format
then
171 return Integer_64
(From_B2U
(R
));
173 return Integer_64
(From_B2
(R
));
184 if Format
in Binary_Unsigned_Format
then
185 return Integer_64
(From_B4U
(R
));
187 return Integer_64
(From_B4
(R
));
198 if Format
in Binary_Unsigned_Format
then
199 return Integer_64
(From_B8U
(R
));
201 return Integer_64
(From_B8
(R
));
205 -- Length is not 1, 2, 4 or 8
208 raise Conversion_Error
;
210 end Binary_To_Decimal
;
212 ------------------------
213 -- Numeric_To_Decimal --
214 ------------------------
216 -- The following assumptions are made in the coding of this routine
218 -- The range of COBOL_Digits is compact and the ten values
219 -- represent the digits 0-9 in sequence
221 -- The range of COBOL_Plus_Digits is compact and the ten values
222 -- represent the digits 0-9 in sequence with a plus sign.
224 -- The range of COBOL_Minus_Digits is compact and the ten values
225 -- represent the digits 0-9 in sequence with a minus sign.
227 -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits
229 -- These assumptions are true for all COBOL representations we know of.
231 function Numeric_To_Decimal
233 Format
: Display_Format
)
236 pragma Unsuppress
(Range_Check
);
237 Sign
: COBOL_Character
:= COBOL_Plus
;
238 Result
: Integer_64
:= 0;
241 if not Valid_Numeric
(Item
, Format
) then
242 raise Conversion_Error
;
245 for J
in Item
'Range loop
247 K
: constant COBOL_Character
:= Item
(J
);
250 if K
in COBOL_Digits
then
251 Result
:= Result
* 10 +
252 (COBOL_Character
'Pos (K
) -
253 COBOL_Character
'Pos (COBOL_Digits
'First));
255 elsif K
in COBOL_Plus_Digits
then
256 Result
:= Result
* 10 +
257 (COBOL_Character
'Pos (K
) -
258 COBOL_Character
'Pos (COBOL_Plus_Digits
'First));
260 elsif K
in COBOL_Minus_Digits
then
261 Result
:= Result
* 10 +
262 (COBOL_Character
'Pos (K
) -
263 COBOL_Character
'Pos (COBOL_Minus_Digits
'First));
266 -- Only remaining possibility is COBOL_Plus or COBOL_Minus
274 if Sign
= COBOL_Plus
then
281 when Constraint_Error
=>
282 raise Conversion_Error
;
284 end Numeric_To_Decimal
;
286 -----------------------
287 -- Packed_To_Decimal --
288 -----------------------
290 function Packed_To_Decimal
291 (Item
: Packed_Decimal
;
292 Format
: Packed_Format
)
295 pragma Unsuppress
(Range_Check
);
296 Result
: Integer_64
:= 0;
297 Sign
: constant Decimal_Element
:= Item
(Item
'Last);
300 if not Valid_Packed
(Item
, Format
) then
301 raise Conversion_Error
;
304 case Packed_Representation
is
306 for J
in Item
'First .. Item
'Last - 1 loop
307 Result
:= Result
* 10 + Integer_64
(Item
(J
));
310 if Sign
= 16#
0B#
or else Sign
= 16#
0D#
then
318 when Constraint_Error
=>
319 raise Conversion_Error
;
320 end Packed_To_Decimal
;
326 procedure Swap
(B
: in out Byte_Array
; F
: Binary_Format
) is
327 Little_Endian
: constant Boolean :=
328 System
.Default_Bit_Order
= System
.Low_Order_First
;
331 -- Return if no swap needed
335 if not Little_Endian
then
340 if Little_Endian
then
348 -- Here a swap is needed
351 Len
: constant Natural := B
'Length;
354 for J
in 1 .. Len
/ 2 loop
356 Temp
: constant Byte
:= B
(J
);
359 B
(J
) := B
(Len
+ 1 - J
);
360 B
(Len
+ 1 - J
) := Temp
;
366 -----------------------
367 -- To_Ada (function) --
368 -----------------------
370 function To_Ada
(Item
: Alphanumeric
) return String is
371 Result
: String (Item
'Range);
374 for J
in Item
'Range loop
375 Result
(J
) := COBOL_To_Ada
(Item
(J
));
381 ------------------------
382 -- To_Ada (procedure) --
383 ------------------------
386 (Item
: Alphanumeric
;
393 if Item
'Length > Target
'Length then
394 raise Constraint_Error
;
397 Last_Val
:= Target
'First - 1;
398 for J
in Item
'Range loop
399 Last_Val
:= Last_Val
+ 1;
400 Target
(Last_Val
) := COBOL_To_Ada
(Item
(J
));
406 -------------------------
407 -- To_COBOL (function) --
408 -------------------------
410 function To_COBOL
(Item
: String) return Alphanumeric
is
411 Result
: Alphanumeric
(Item
'Range);
414 for J
in Item
'Range loop
415 Result
(J
) := Ada_To_COBOL
(Item
(J
));
421 --------------------------
422 -- To_COBOL (procedure) --
423 --------------------------
427 Target
: out Alphanumeric
;
433 if Item
'Length > Target
'Length then
434 raise Constraint_Error
;
437 Last_Val
:= Target
'First - 1;
438 for J
in Item
'Range loop
439 Last_Val
:= Last_Val
+ 1;
440 Target
(Last_Val
) := Ada_To_COBOL
(Item
(J
));
452 Format
: Display_Format
;
456 Result
: Numeric
(1 .. Length
);
457 Val
: Integer_64
:= Item
;
459 procedure Convert
(First
, Last
: Natural);
460 -- Convert the number in Val into COBOL_Digits, storing the result
461 -- in Result (First .. Last). Raise Conversion_Error if too large.
463 procedure Embed_Sign
(Loc
: Natural);
464 -- Used for the nonseparate formats to embed the appropriate sign
465 -- at the specified location (i.e. at Result (Loc))
467 procedure Convert
(First
, Last
: Natural) is
471 while J
>= First
loop
474 (COBOL_Character
'Pos (COBOL_Digits
'First) +
475 Integer (Val
mod 10));
479 for K
in First
.. J
- 1 loop
480 Result
(J
) := COBOL_Digits
'First;
490 raise Conversion_Error
;
493 procedure Embed_Sign
(Loc
: Natural) is
494 Digit
: Natural range 0 .. 9;
497 Digit
:= COBOL_Character
'Pos (Result
(Loc
)) -
498 COBOL_Character
'Pos (COBOL_Digits
'First);
503 (COBOL_Character
'Pos (COBOL_Plus_Digits
'First) + Digit
);
507 (COBOL_Character
'Pos (COBOL_Minus_Digits
'First) + Digit
);
511 -- Start of processing for To_Display
517 raise Conversion_Error
;
522 when Leading_Separate
=>
524 Result
(1) := COBOL_Minus
;
527 Result
(1) := COBOL_Plus
;
532 when Trailing_Separate
=>
534 Result
(Length
) := COBOL_Minus
;
537 Result
(Length
) := COBOL_Plus
;
540 Convert
(1, Length
- 1);
542 when Leading_Nonseparate
=>
547 when Trailing_Nonseparate
=>
563 Format
: Packed_Format
;
565 return Packed_Decimal
567 Result
: Packed_Decimal
(1 .. Length
);
570 procedure Convert
(First
, Last
: Natural);
571 -- Convert the number in Val into a sequence of Decimal_Element values,
572 -- storing the result in Result (First .. Last). Raise Conversion_Error
573 -- if the value is too large to fit.
575 procedure Convert
(First
, Last
: Natural) is
579 while J
>= First
loop
580 Result
(J
) := Decimal_Element
(Val
mod 10);
585 for K
in First
.. J
- 1 loop
596 raise Conversion_Error
;
599 -- Start of processing for To_Packed
602 case Packed_Representation
is
604 if Format
= Packed_Unsigned
then
606 raise Conversion_Error
;
608 Result
(Length
) := 16#F#
;
613 Result
(Length
) := 16#C#
;
617 Result
(Length
) := 16#D#
;
621 Convert
(1, Length
- 1);
630 function Valid_Numeric
632 Format
: Display_Format
)
636 -- All character positions except first and last must be Digits.
637 -- This is true for all the formats.
639 for J
in Item
'First + 1 .. Item
'Last - 1 loop
640 if Item
(J
) not in COBOL_Digits
then
647 return Item
(Item
'First) in COBOL_Digits
648 and then Item
(Item
'Last) in COBOL_Digits
;
650 when Leading_Separate
=>
651 return (Item
(Item
'First) = COBOL_Plus
or else
652 Item
(Item
'First) = COBOL_Minus
)
653 and then Item
(Item
'Last) in COBOL_Digits
;
655 when Trailing_Separate
=>
656 return Item
(Item
'First) in COBOL_Digits
658 (Item
(Item
'Last) = COBOL_Plus
or else
659 Item
(Item
'Last) = COBOL_Minus
);
661 when Leading_Nonseparate
=>
662 return (Item
(Item
'First) in COBOL_Plus_Digits
or else
663 Item
(Item
'First) in COBOL_Minus_Digits
)
664 and then Item
(Item
'Last) in COBOL_Digits
;
666 when Trailing_Nonseparate
=>
667 return Item
(Item
'First) in COBOL_Digits
669 (Item
(Item
'Last) in COBOL_Plus_Digits
or else
670 Item
(Item
'Last) in COBOL_Minus_Digits
);
679 function Valid_Packed
680 (Item
: Packed_Decimal
;
681 Format
: Packed_Format
)
685 case Packed_Representation
is
687 for J
in Item
'First .. Item
'Last - 1 loop
693 -- For unsigned, sign digit must be F
695 if Format
= Packed_Unsigned
then
696 return Item
(Item
'Last) = 16#F#
;
698 -- For signed, accept all standard and non-standard signs
701 return Item
(Item
'Last) in 16#A#
.. 16#F#
;
706 -------------------------
707 -- Decimal_Conversions --
708 -------------------------
710 package body Decimal_Conversions
is
712 ---------------------
713 -- Length (binary) --
714 ---------------------
716 -- Note that the tests here are all compile time tests
718 function Length
(Format
: Binary_Format
) return Natural is
719 pragma Warnings
(Off
, Format
);
722 if Num
'Digits <= 2 then
725 elsif Num
'Digits <= 4 then
728 elsif Num
'Digits <= 9 then
731 else -- Num'Digits in 10 .. 18
736 ----------------------
737 -- Length (display) --
738 ----------------------
740 function Length
(Format
: Display_Format
) return Natural is
742 if Format
= Leading_Separate
or else Format
= Trailing_Separate
then
743 return Num
'Digits + 1;
749 ---------------------
750 -- Length (packed) --
751 ---------------------
753 -- Note that the tests here are all compile time checks
756 (Format
: Packed_Format
)
759 pragma Warnings
(Off
, Format
);
762 case Packed_Representation
is
764 return (Num
'Digits + 2) / 2 * 2;
774 Format
: Binary_Format
)
778 -- Note: all these tests are compile time tests
780 if Num
'Digits <= 2 then
781 return To_B1
(Integer_8
'Integer_Value (Item
));
783 elsif Num
'Digits <= 4 then
785 R
: B2
:= To_B2
(Integer_16
'Integer_Value (Item
));
792 elsif Num
'Digits <= 9 then
794 R
: B4
:= To_B4
(Integer_32
'Integer_Value (Item
));
801 else -- Num'Digits in 10 .. 18
803 R
: B8
:= To_B8
(Integer_64
'Integer_Value (Item
));
812 when Constraint_Error
=>
813 raise Conversion_Error
;
816 ---------------------------------
817 -- To_Binary (internal binary) --
818 ---------------------------------
820 function To_Binary
(Item
: Num
) return Binary
is
821 pragma Unsuppress
(Range_Check
);
823 return Binary
'Integer_Value (Item
);
826 when Constraint_Error
=>
827 raise Conversion_Error
;
830 -------------------------
831 -- To_Decimal (binary) --
832 -------------------------
836 Format
: Binary_Format
)
839 pragma Unsuppress
(Range_Check
);
842 return Num
'Fixed_Value (Binary_To_Decimal
(Item
, Format
));
845 when Constraint_Error
=>
846 raise Conversion_Error
;
849 ----------------------------------
850 -- To_Decimal (internal binary) --
851 ----------------------------------
853 function To_Decimal
(Item
: Binary
) return Num
is
854 pragma Unsuppress
(Range_Check
);
857 return Num
'Fixed_Value (Item
);
860 when Constraint_Error
=>
861 raise Conversion_Error
;
864 --------------------------
865 -- To_Decimal (display) --
866 --------------------------
870 Format
: Display_Format
)
873 pragma Unsuppress
(Range_Check
);
876 return Num
'Fixed_Value (Numeric_To_Decimal
(Item
, Format
));
879 when Constraint_Error
=>
880 raise Conversion_Error
;
883 ---------------------------------------
884 -- To_Decimal (internal long binary) --
885 ---------------------------------------
887 function To_Decimal
(Item
: Long_Binary
) return Num
is
888 pragma Unsuppress
(Range_Check
);
891 return Num
'Fixed_Value (Item
);
894 when Constraint_Error
=>
895 raise Conversion_Error
;
898 -------------------------
899 -- To_Decimal (packed) --
900 -------------------------
903 (Item
: Packed_Decimal
;
904 Format
: Packed_Format
)
907 pragma Unsuppress
(Range_Check
);
910 return Num
'Fixed_Value (Packed_To_Decimal
(Item
, Format
));
913 when Constraint_Error
=>
914 raise Conversion_Error
;
923 Format
: Display_Format
)
926 pragma Unsuppress
(Range_Check
);
931 (Integer_64
'Integer_Value (Item
),
936 when Constraint_Error
=>
937 raise Conversion_Error
;
944 function To_Long_Binary
(Item
: Num
) return Long_Binary
is
945 pragma Unsuppress
(Range_Check
);
948 return Long_Binary
'Integer_Value (Item
);
951 when Constraint_Error
=>
952 raise Conversion_Error
;
961 Format
: Packed_Format
)
962 return Packed_Decimal
964 pragma Unsuppress
(Range_Check
);
969 (Integer_64
'Integer_Value (Item
),
974 when Constraint_Error
=>
975 raise Conversion_Error
;
984 Format
: Binary_Format
)
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
;