1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- I N T E R F A C E S . P A C K E D _ D E C I M A L --
8 -- (Version for IBM Mainframe Packed Decimal Format) --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 with System
; use System
;
37 with Unchecked_Conversion
;
39 package body Interfaces
.Packed_Decimal
is
41 type Packed
is array (Byte_Length
) of Unsigned_8
;
42 -- The type used internally to represent packed decimal
44 type Packed_Ptr
is access Packed
;
45 function To_Packed_Ptr
is new Unchecked_Conversion
(Address
, Packed_Ptr
);
47 -- The following array is used to convert a value in the range 0-99 to
48 -- a packed decimal format with two hexadecimal nibbles. It is worth
49 -- using table look up in this direction because divides are expensive.
51 Packed_Byte
: constant array (00 .. 99) of Unsigned_8
:=
52 (16#
00#
, 16#
01#
, 16#
02#
, 16#
03#
, 16#
04#
,
53 16#
05#
, 16#
06#
, 16#
07#
, 16#
08#
, 16#
09#
,
54 16#
10#
, 16#
11#
, 16#
12#
, 16#
13#
, 16#
14#
,
55 16#
15#
, 16#
16#
, 16#
17#
, 16#
18#
, 16#
19#
,
56 16#
20#
, 16#
21#
, 16#
22#
, 16#
23#
, 16#
24#
,
57 16#
25#
, 16#
26#
, 16#
27#
, 16#
28#
, 16#
29#
,
58 16#
30#
, 16#
31#
, 16#
32#
, 16#
33#
, 16#
34#
,
59 16#
35#
, 16#
36#
, 16#
37#
, 16#
38#
, 16#
39#
,
60 16#
40#
, 16#
41#
, 16#
42#
, 16#
43#
, 16#
44#
,
61 16#
45#
, 16#
46#
, 16#
47#
, 16#
48#
, 16#
49#
,
62 16#
50#
, 16#
51#
, 16#
52#
, 16#
53#
, 16#
54#
,
63 16#
55#
, 16#
56#
, 16#
57#
, 16#
58#
, 16#
59#
,
64 16#
60#
, 16#
61#
, 16#
62#
, 16#
63#
, 16#
64#
,
65 16#
65#
, 16#
66#
, 16#
67#
, 16#
68#
, 16#
69#
,
66 16#
70#
, 16#
71#
, 16#
72#
, 16#
73#
, 16#
74#
,
67 16#
75#
, 16#
76#
, 16#
77#
, 16#
78#
, 16#
79#
,
68 16#
80#
, 16#
81#
, 16#
82#
, 16#
83#
, 16#
84#
,
69 16#
85#
, 16#
86#
, 16#
87#
, 16#
88#
, 16#
89#
,
70 16#
90#
, 16#
91#
, 16#
92#
, 16#
93#
, 16#
94#
,
71 16#
95#
, 16#
96#
, 16#
97#
, 16#
98#
, 16#
99#
);
77 procedure Int32_To_Packed
(V
: Integer_32
; P
: System
.Address
; D
: D32
) is
78 PP
: constant Packed_Ptr
:= To_Packed_Ptr
(P
);
79 Empty_Nibble
: constant Boolean := ((D
rem 2) = 0);
80 B
: constant Byte_Length
:= (D
/ 2) + 1;
84 -- Deal with sign byte first
87 PP
(B
) := Unsigned_8
(VV
rem 10) * 16 + 16#C#
;
92 PP
(B
) := Unsigned_8
(VV
rem 10) * 16 + 16#D#
;
95 for J
in reverse B
- 1 .. 2 loop
104 PP
(J
) := Packed_Byte
(Integer (VV
rem 100));
109 -- Deal with leading byte
113 raise Constraint_Error
;
115 PP
(1) := Unsigned_8
(VV
);
120 raise Constraint_Error
;
122 PP
(1) := Packed_Byte
(Integer (VV
));
128 ---------------------
129 -- Int64_To_Packed --
130 ---------------------
132 procedure Int64_To_Packed
(V
: Integer_64
; P
: System
.Address
; D
: D64
) is
133 PP
: constant Packed_Ptr
:= To_Packed_Ptr
(P
);
134 Empty_Nibble
: constant Boolean := ((D
rem 2) = 0);
135 B
: constant Byte_Length
:= (D
/ 2) + 1;
136 VV
: Integer_64
:= V
;
139 -- Deal with sign byte first
142 PP
(B
) := Unsigned_8
(VV
rem 10) * 16 + 16#C#
;
147 PP
(B
) := Unsigned_8
(VV
rem 10) * 16 + 16#D#
;
150 for J
in reverse B
- 1 .. 2 loop
159 PP
(J
) := Packed_Byte
(Integer (VV
rem 100));
164 -- Deal with leading byte
168 raise Constraint_Error
;
170 PP
(1) := Unsigned_8
(VV
);
175 raise Constraint_Error
;
177 PP
(1) := Packed_Byte
(Integer (VV
));
183 ---------------------
184 -- Packed_To_Int32 --
185 ---------------------
187 function Packed_To_Int32
(P
: System
.Address
; D
: D32
) return Integer_32
is
188 PP
: constant Packed_Ptr
:= To_Packed_Ptr
(P
);
189 Empty_Nibble
: constant Boolean := ((D
mod 2) = 0);
190 B
: constant Byte_Length
:= (D
/ 2) + 1;
197 -- Cases where there is an unused (zero) nibble in the first byte.
198 -- Deal with the single digit nibble at the right of this byte
201 V
:= Integer_32
(PP
(1));
205 raise Constraint_Error
;
208 -- Cases where all nibbles are used
215 -- Loop to process bytes containing two digit nibbles
218 Dig
:= Shift_Right
(PP
(J
), 4);
221 raise Constraint_Error
;
223 V
:= V
* 10 + Integer_32
(Dig
);
226 Dig
:= PP
(J
) and 16#
0F#
;
229 raise Constraint_Error
;
231 V
:= V
* 10 + Integer_32
(Dig
);
237 -- Deal with digit nibble in sign byte
239 Dig
:= Shift_Right
(PP
(J
), 4);
242 raise Constraint_Error
;
244 V
:= V
* 10 + Integer_32
(Dig
);
247 Sign
:= PP
(J
) and 16#
0F#
;
249 -- Process sign nibble (deal with most common cases first)
254 elsif Sign
= 16#D#
then
257 elsif Sign
= 16#B#
then
260 elsif Sign
>= 16#A#
then
264 raise Constraint_Error
;
268 ---------------------
269 -- Packed_To_Int64 --
270 ---------------------
272 function Packed_To_Int64
(P
: System
.Address
; D
: D64
) return Integer_64
is
273 PP
: constant Packed_Ptr
:= To_Packed_Ptr
(P
);
274 Empty_Nibble
: constant Boolean := ((D
mod 2) = 0);
275 B
: constant Byte_Length
:= (D
/ 2) + 1;
282 -- Cases where there is an unused (zero) nibble in the first byte.
283 -- Deal with the single digit nibble at the right of this byte
286 V
:= Integer_64
(PP
(1));
290 raise Constraint_Error
;
293 -- Cases where all nibbles are used
300 -- Loop to process bytes containing two digit nibbles
303 Dig
:= Shift_Right
(PP
(J
), 4);
306 raise Constraint_Error
;
308 V
:= V
* 10 + Integer_64
(Dig
);
311 Dig
:= PP
(J
) and 16#
0F#
;
314 raise Constraint_Error
;
316 V
:= V
* 10 + Integer_64
(Dig
);
322 -- Deal with digit nibble in sign byte
324 Dig
:= Shift_Right
(PP
(J
), 4);
327 raise Constraint_Error
;
329 V
:= V
* 10 + Integer_64
(Dig
);
332 Sign
:= PP
(J
) and 16#
0F#
;
334 -- Process sign nibble (deal with most common cases first)
339 elsif Sign
= 16#D#
then
342 elsif Sign
= 16#B#
then
345 elsif Sign
>= 16#A#
then
349 raise Constraint_Error
;
353 end Interfaces
.Packed_Decimal
;