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) --
10 -- Copyright (C) 1992-2007, 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, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, 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 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 with System; use System;
37 with Ada.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
46 new Ada.Unchecked_Conversion (Address, Packed_Ptr);
48 -- The following array is used to convert a value in the range 0-99 to
49 -- a packed decimal format with two hexadecimal nibbles. It is worth
50 -- using table look up in this direction because divides are expensive.
52 Packed_Byte : constant array (00 .. 99) of Unsigned_8 :=
53 (16#00#, 16#01#, 16#02#, 16#03#, 16#04#,
54 16#05#, 16#06#, 16#07#, 16#08#, 16#09#,
55 16#10#, 16#11#, 16#12#, 16#13#, 16#14#,
56 16#15#, 16#16#, 16#17#, 16#18#, 16#19#,
57 16#20#, 16#21#, 16#22#, 16#23#, 16#24#,
58 16#25#, 16#26#, 16#27#, 16#28#, 16#29#,
59 16#30#, 16#31#, 16#32#, 16#33#, 16#34#,
60 16#35#, 16#36#, 16#37#, 16#38#, 16#39#,
61 16#40#, 16#41#, 16#42#, 16#43#, 16#44#,
62 16#45#, 16#46#, 16#47#, 16#48#, 16#49#,
63 16#50#, 16#51#, 16#52#, 16#53#, 16#54#,
64 16#55#, 16#56#, 16#57#, 16#58#, 16#59#,
65 16#60#, 16#61#, 16#62#, 16#63#, 16#64#,
66 16#65#, 16#66#, 16#67#, 16#68#, 16#69#,
67 16#70#, 16#71#, 16#72#, 16#73#, 16#74#,
68 16#75#, 16#76#, 16#77#, 16#78#, 16#79#,
69 16#80#, 16#81#, 16#82#, 16#83#, 16#84#,
70 16#85#, 16#86#, 16#87#, 16#88#, 16#89#,
71 16#90#, 16#91#, 16#92#, 16#93#, 16#94#,
72 16#95#, 16#96#, 16#97#, 16#98#, 16#99#);
78 procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is
79 PP : constant Packed_Ptr := To_Packed_Ptr (P);
80 Empty_Nibble : constant Boolean := ((D rem 2) = 0);
81 B : constant Byte_Length := (D / 2) + 1;
85 -- Deal with sign byte first
88 PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
93 PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
96 for J in reverse B - 1 .. 2 loop
105 PP (J) := Packed_Byte (Integer (VV rem 100));
110 -- Deal with leading byte
114 raise Constraint_Error;
116 PP (1) := Unsigned_8 (VV);
121 raise Constraint_Error;
123 PP (1) := Packed_Byte (Integer (VV));
129 ---------------------
130 -- Int64_To_Packed --
131 ---------------------
133 procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is
134 PP : constant Packed_Ptr := To_Packed_Ptr (P);
135 Empty_Nibble : constant Boolean := ((D rem 2) = 0);
136 B : constant Byte_Length := (D / 2) + 1;
137 VV : Integer_64 := V;
140 -- Deal with sign byte first
143 PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
148 PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
151 for J in reverse B - 1 .. 2 loop
160 PP (J) := Packed_Byte (Integer (VV rem 100));
165 -- Deal with leading byte
169 raise Constraint_Error;
171 PP (1) := Unsigned_8 (VV);
176 raise Constraint_Error;
178 PP (1) := Packed_Byte (Integer (VV));
184 ---------------------
185 -- Packed_To_Int32 --
186 ---------------------
188 function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is
189 PP : constant Packed_Ptr := To_Packed_Ptr (P);
190 Empty_Nibble : constant Boolean := ((D mod 2) = 0);
191 B : constant Byte_Length := (D / 2) + 1;
198 -- Cases where there is an unused (zero) nibble in the first byte.
199 -- Deal with the single digit nibble at the right of this byte
202 V := Integer_32 (PP (1));
206 raise Constraint_Error;
209 -- Cases where all nibbles are used
216 -- Loop to process bytes containing two digit nibbles
219 Dig := Shift_Right (PP (J), 4);
222 raise Constraint_Error;
224 V := V * 10 + Integer_32 (Dig);
227 Dig := PP (J) and 16#0F#;
230 raise Constraint_Error;
232 V := V * 10 + Integer_32 (Dig);
238 -- Deal with digit nibble in sign byte
240 Dig := Shift_Right (PP (J), 4);
243 raise Constraint_Error;
245 V := V * 10 + Integer_32 (Dig);
248 Sign := PP (J) and 16#0F#;
250 -- Process sign nibble (deal with most common cases first)
255 elsif Sign = 16#D# then
258 elsif Sign = 16#B# then
261 elsif Sign >= 16#A# then
265 raise Constraint_Error;
269 ---------------------
270 -- Packed_To_Int64 --
271 ---------------------
273 function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is
274 PP : constant Packed_Ptr := To_Packed_Ptr (P);
275 Empty_Nibble : constant Boolean := ((D mod 2) = 0);
276 B : constant Byte_Length := (D / 2) + 1;
283 -- Cases where there is an unused (zero) nibble in the first byte.
284 -- Deal with the single digit nibble at the right of this byte
287 V := Integer_64 (PP (1));
291 raise Constraint_Error;
294 -- Cases where all nibbles are used
301 -- Loop to process bytes containing two digit nibbles
304 Dig := Shift_Right (PP (J), 4);
307 raise Constraint_Error;
309 V := V * 10 + Integer_64 (Dig);
312 Dig := PP (J) and 16#0F#;
315 raise Constraint_Error;
317 V := V * 10 + Integer_64 (Dig);
323 -- Deal with digit nibble in sign byte
325 Dig := Shift_Right (PP (J), 4);
328 raise Constraint_Error;
330 V := V * 10 + Integer_64 (Dig);
333 Sign := PP (J) and 16#0F#;
335 -- Process sign nibble (deal with most common cases first)
340 elsif Sign = 16#D# then
343 elsif Sign = 16#B# then
346 elsif Sign >= 16#A# then
350 raise Constraint_Error;
354 end Interfaces.Packed_Decimal;