URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [i-pacdec.adb] - Blame information for rev 706

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--            I N T E R F A C E S . P A C K E D _ D E C I M A L             --
--                                                                          --
--                                 B o d y                                  --
--            (Version for IBM Mainframe Packed Decimal Format)             --
--                                                                          --
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with System; use System;
 
with Ada.Unchecked_Conversion;
 
package body Interfaces.Packed_Decimal is
 
   type Packed is array (Byte_Length) of Unsigned_8;
   --  The type used internally to represent packed decimal
 
   type Packed_Ptr is access Packed;
   function To_Packed_Ptr is
     new Ada.Unchecked_Conversion (Address, Packed_Ptr);
 
   --  The following array is used to convert a value in the range 0-99 to
   --  a packed decimal format with two hexadecimal nibbles. It is worth
   --  using table look up in this direction because divides are expensive.
 
   Packed_Byte : constant array (00 .. 99) of Unsigned_8 :=
      (16#00#, 16#01#, 16#02#, 16#03#, 16#04#,
       16#05#, 16#06#, 16#07#, 16#08#, 16#09#,
       16#10#, 16#11#, 16#12#, 16#13#, 16#14#,
       16#15#, 16#16#, 16#17#, 16#18#, 16#19#,
       16#20#, 16#21#, 16#22#, 16#23#, 16#24#,
       16#25#, 16#26#, 16#27#, 16#28#, 16#29#,
       16#30#, 16#31#, 16#32#, 16#33#, 16#34#,
       16#35#, 16#36#, 16#37#, 16#38#, 16#39#,
       16#40#, 16#41#, 16#42#, 16#43#, 16#44#,
       16#45#, 16#46#, 16#47#, 16#48#, 16#49#,
       16#50#, 16#51#, 16#52#, 16#53#, 16#54#,
       16#55#, 16#56#, 16#57#, 16#58#, 16#59#,
       16#60#, 16#61#, 16#62#, 16#63#, 16#64#,
       16#65#, 16#66#, 16#67#, 16#68#, 16#69#,
       16#70#, 16#71#, 16#72#, 16#73#, 16#74#,
       16#75#, 16#76#, 16#77#, 16#78#, 16#79#,
       16#80#, 16#81#, 16#82#, 16#83#, 16#84#,
       16#85#, 16#86#, 16#87#, 16#88#, 16#89#,
       16#90#, 16#91#, 16#92#, 16#93#, 16#94#,
       16#95#, 16#96#, 16#97#, 16#98#, 16#99#);
 
   ---------------------
   -- Int32_To_Packed --
   ---------------------
 
   procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is
      PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
      Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
      B            : constant Byte_Length := (D / 2) + 1;
      VV           : Integer_32 := V;
 
   begin
      --  Deal with sign byte first
 
      if VV >= 0 then
         PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
         VV := VV / 10;
 
      else
         VV := -VV;
         PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
      end if;
 
      for J in reverse B - 1 .. 2 loop
         if VV = 0 then
            for K in 1 .. J loop
               PP (K) := 16#00#;
            end loop;
 
            return;
 
         else
            PP (J) := Packed_Byte (Integer (VV rem 100));
            VV := VV / 100;
         end if;
      end loop;
 
      --  Deal with leading byte
 
      if Empty_Nibble then
         if VV > 9 then
            raise Constraint_Error;
         else
            PP (1) := Unsigned_8 (VV);
         end if;
 
      else
         if VV > 99 then
            raise Constraint_Error;
         else
            PP (1) := Packed_Byte (Integer (VV));
         end if;
      end if;
 
   end Int32_To_Packed;
 
   ---------------------
   -- Int64_To_Packed --
   ---------------------
 
   procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is
      PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
      Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
      B            : constant Byte_Length := (D / 2) + 1;
      VV           : Integer_64 := V;
 
   begin
      --  Deal with sign byte first
 
      if VV >= 0 then
         PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
         VV := VV / 10;
 
      else
         VV := -VV;
         PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
      end if;
 
      for J in reverse B - 1 .. 2 loop
         if VV = 0 then
            for K in 1 .. J loop
               PP (K) := 16#00#;
            end loop;
 
            return;
 
         else
            PP (J) := Packed_Byte (Integer (VV rem 100));
            VV := VV / 100;
         end if;
      end loop;
 
      --  Deal with leading byte
 
      if Empty_Nibble then
         if VV > 9 then
            raise Constraint_Error;
         else
            PP (1) := Unsigned_8 (VV);
         end if;
 
      else
         if VV > 99 then
            raise Constraint_Error;
         else
            PP (1) := Packed_Byte (Integer (VV));
         end if;
      end if;
 
   end Int64_To_Packed;
 
   ---------------------
   -- Packed_To_Int32 --
   ---------------------
 
   function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is
      PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
      Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
      B            : constant Byte_Length := (D / 2) + 1;
      V            : Integer_32;
      Dig          : Unsigned_8;
      Sign         : Unsigned_8;
      J            : Positive;
 
   begin
      --  Cases where there is an unused (zero) nibble in the first byte.
      --  Deal with the single digit nibble at the right of this byte
 
      if Empty_Nibble then
         V := Integer_32 (PP (1));
         J := 2;
 
         if V > 9 then
            raise Constraint_Error;
         end if;
 
      --  Cases where all nibbles are used
 
      else
         V := 0;
         J := 1;
      end if;
 
      --  Loop to process bytes containing two digit nibbles
 
      while J < B loop
         Dig := Shift_Right (PP (J), 4);
 
         if Dig > 9 then
            raise Constraint_Error;
         else
            V := V * 10 + Integer_32 (Dig);
         end if;
 
         Dig := PP (J) and 16#0F#;
 
         if Dig > 9 then
            raise Constraint_Error;
         else
            V := V * 10 + Integer_32 (Dig);
         end if;
 
         J := J + 1;
      end loop;
 
      --  Deal with digit nibble in sign byte
 
      Dig := Shift_Right (PP (J), 4);
 
      if Dig > 9 then
         raise Constraint_Error;
      else
         V := V * 10 + Integer_32 (Dig);
      end if;
 
      Sign :=  PP (J) and 16#0F#;
 
      --  Process sign nibble (deal with most common cases first)
 
      if Sign = 16#C# then
         return V;
 
      elsif Sign = 16#D# then
         return -V;
 
      elsif Sign = 16#B# then
         return -V;
 
      elsif Sign >= 16#A# then
         return V;
 
      else
         raise Constraint_Error;
      end if;
   end Packed_To_Int32;
 
   ---------------------
   -- Packed_To_Int64 --
   ---------------------
 
   function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is
      PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
      Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
      B            : constant Byte_Length := (D / 2) + 1;
      V            : Integer_64;
      Dig          : Unsigned_8;
      Sign         : Unsigned_8;
      J            : Positive;
 
   begin
      --  Cases where there is an unused (zero) nibble in the first byte.
      --  Deal with the single digit nibble at the right of this byte
 
      if Empty_Nibble then
         V := Integer_64 (PP (1));
         J := 2;
 
         if V > 9 then
            raise Constraint_Error;
         end if;
 
      --  Cases where all nibbles are used
 
      else
         J := 1;
         V := 0;
      end if;
 
      --  Loop to process bytes containing two digit nibbles
 
      while J < B loop
         Dig := Shift_Right (PP (J), 4);
 
         if Dig > 9 then
            raise Constraint_Error;
         else
            V := V * 10 + Integer_64 (Dig);
         end if;
 
         Dig := PP (J) and 16#0F#;
 
         if Dig > 9 then
            raise Constraint_Error;
         else
            V := V * 10 + Integer_64 (Dig);
         end if;
 
         J := J + 1;
      end loop;
 
      --  Deal with digit nibble in sign byte
 
      Dig := Shift_Right (PP (J), 4);
 
      if Dig > 9 then
         raise Constraint_Error;
      else
         V := V * 10 + Integer_64 (Dig);
      end if;
 
      Sign :=  PP (J) and 16#0F#;
 
      --  Process sign nibble (deal with most common cases first)
 
      if Sign = 16#C# then
         return V;
 
      elsif Sign = 16#D# then
         return -V;
 
      elsif Sign = 16#B# then
         return -V;
 
      elsif Sign >= 16#A# then
         return V;
 
      else
         raise Constraint_Error;
      end if;
   end Packed_To_Int64;
 
end Interfaces.Packed_Decimal;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [i-pacdec.adb] - Blame information for rev 706

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- I N T E R F A C E S . P A C K E D _ D E C I M A L --`
6			`-- --`
7			`-- B o d y --`
8			`-- (Version for IBM Mainframe Packed Decimal Format) --`
9			`-- --`
10			`-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --`
11			`-- --`
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 3, 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. --`
18			`-- --`
19			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
20			`-- additional permissions described in the GCC Runtime Library Exception, --`
21			`-- version 3.1, as published by the Free Software Foundation. --`
22			`-- --`
23			`-- You should have received a copy of the GNU General Public License and --`
24			`-- a copy of the GCC Runtime Library Exception along with this program; --`
25			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
26			`-- <http://www.gnu.org/licenses/>. --`
27			`-- --`
28			`-- GNAT was originally developed by the GNAT team at New York University. --`
29			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
30			`-- --`
31			`------------------------------------------------------------------------------`
32
33			`with System; use System;`
34
35			`with Ada.Unchecked_Conversion;`
36
37			`package body Interfaces.Packed_Decimal is`
38
39			`type Packed is array (Byte_Length) of Unsigned_8;`
40			`-- The type used internally to represent packed decimal`
41
42			`type Packed_Ptr is access Packed;`
43			`function To_Packed_Ptr is`
44			`new Ada.Unchecked_Conversion (Address, Packed_Ptr);`
45
46			`-- The following array is used to convert a value in the range 0-99 to`
47			`-- a packed decimal format with two hexadecimal nibbles. It is worth`
48			`-- using table look up in this direction because divides are expensive.`
49
50			`Packed_Byte : constant array (00 .. 99) of Unsigned_8 :=`
51			`(16#00#, 16#01#, 16#02#, 16#03#, 16#04#,`
52			`16#05#, 16#06#, 16#07#, 16#08#, 16#09#,`
53			`16#10#, 16#11#, 16#12#, 16#13#, 16#14#,`
54			`16#15#, 16#16#, 16#17#, 16#18#, 16#19#,`
55			`16#20#, 16#21#, 16#22#, 16#23#, 16#24#,`
56			`16#25#, 16#26#, 16#27#, 16#28#, 16#29#,`
57			`16#30#, 16#31#, 16#32#, 16#33#, 16#34#,`
58			`16#35#, 16#36#, 16#37#, 16#38#, 16#39#,`
59			`16#40#, 16#41#, 16#42#, 16#43#, 16#44#,`
60			`16#45#, 16#46#, 16#47#, 16#48#, 16#49#,`
61			`16#50#, 16#51#, 16#52#, 16#53#, 16#54#,`
62			`16#55#, 16#56#, 16#57#, 16#58#, 16#59#,`
63			`16#60#, 16#61#, 16#62#, 16#63#, 16#64#,`
64			`16#65#, 16#66#, 16#67#, 16#68#, 16#69#,`
65			`16#70#, 16#71#, 16#72#, 16#73#, 16#74#,`
66			`16#75#, 16#76#, 16#77#, 16#78#, 16#79#,`
67			`16#80#, 16#81#, 16#82#, 16#83#, 16#84#,`
68			`16#85#, 16#86#, 16#87#, 16#88#, 16#89#,`
69			`16#90#, 16#91#, 16#92#, 16#93#, 16#94#,`
70			`16#95#, 16#96#, 16#97#, 16#98#, 16#99#);`
71
72			`---------------------`
73			`-- Int32_To_Packed --`
74			`---------------------`
75
76			`procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is`
77			`PP : constant Packed_Ptr := To_Packed_Ptr (P);`
78			`Empty_Nibble : constant Boolean := ((D rem 2) = 0);`
79			`B : constant Byte_Length := (D / 2) + 1;`
80			`VV : Integer_32 := V;`
81
82			`begin`
83			`-- Deal with sign byte first`
84
85			`if VV >= 0 then`
86			`PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;`
87			`VV := VV / 10;`
88
89			`else`
90			`VV := -VV;`
91			`PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;`
92			`end if;`
93
94			`for J in reverse B - 1 .. 2 loop`
95			`if VV = 0 then`
96			`for K in 1 .. J loop`
97			`PP (K) := 16#00#;`
98			`end loop;`
99
100			`return;`
101
102			`else`
103			`PP (J) := Packed_Byte (Integer (VV rem 100));`
104			`VV := VV / 100;`
105			`end if;`
106			`end loop;`
107
108			`-- Deal with leading byte`
109
110			`if Empty_Nibble then`
111			`if VV > 9 then`
112			`raise Constraint_Error;`
113			`else`
114			`PP (1) := Unsigned_8 (VV);`
115			`end if;`
116
117			`else`
118			`if VV > 99 then`
119			`raise Constraint_Error;`
120			`else`
121			`PP (1) := Packed_Byte (Integer (VV));`
122			`end if;`
123			`end if;`
124
125			`end Int32_To_Packed;`
126
127			`---------------------`
128			`-- Int64_To_Packed --`
129			`---------------------`
130
131			`procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is`
132			`PP : constant Packed_Ptr := To_Packed_Ptr (P);`
133			`Empty_Nibble : constant Boolean := ((D rem 2) = 0);`
134			`B : constant Byte_Length := (D / 2) + 1;`
135			`VV : Integer_64 := V;`
136
137			`begin`
138			`-- Deal with sign byte first`
139
140			`if VV >= 0 then`
141			`PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;`
142			`VV := VV / 10;`
143
144			`else`
145			`VV := -VV;`
146			`PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;`
147			`end if;`
148
149			`for J in reverse B - 1 .. 2 loop`
150			`if VV = 0 then`
151			`for K in 1 .. J loop`
152			`PP (K) := 16#00#;`
153			`end loop;`
154
155			`return;`
156
157			`else`
158			`PP (J) := Packed_Byte (Integer (VV rem 100));`
159			`VV := VV / 100;`
160			`end if;`
161			`end loop;`
162
163			`-- Deal with leading byte`
164
165			`if Empty_Nibble then`
166			`if VV > 9 then`
167			`raise Constraint_Error;`
168			`else`
169			`PP (1) := Unsigned_8 (VV);`
170			`end if;`
171
172			`else`
173			`if VV > 99 then`
174			`raise Constraint_Error;`
175			`else`
176			`PP (1) := Packed_Byte (Integer (VV));`
177			`end if;`
178			`end if;`
179
180			`end Int64_To_Packed;`
181
182			`---------------------`
183			`-- Packed_To_Int32 --`
184			`---------------------`
185
186			`function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is`
187			`PP : constant Packed_Ptr := To_Packed_Ptr (P);`
188			`Empty_Nibble : constant Boolean := ((D mod 2) = 0);`
189			`B : constant Byte_Length := (D / 2) + 1;`
190			`V : Integer_32;`
191			`Dig : Unsigned_8;`
192			`Sign : Unsigned_8;`
193			`J : Positive;`
194
195			`begin`
196			`-- Cases where there is an unused (zero) nibble in the first byte.`
197			`-- Deal with the single digit nibble at the right of this byte`
198
199			`if Empty_Nibble then`
200			`V := Integer_32 (PP (1));`
201			`J := 2;`
202
203			`if V > 9 then`
204			`raise Constraint_Error;`
205			`end if;`
206
207			`-- Cases where all nibbles are used`
208
209			`else`
210			`V := 0;`
211			`J := 1;`
212			`end if;`
213
214			`-- Loop to process bytes containing two digit nibbles`
215
216			`while J < B loop`
217			`Dig := Shift_Right (PP (J), 4);`
218
219			`if Dig > 9 then`
220			`raise Constraint_Error;`
221			`else`
222			`V := V * 10 + Integer_32 (Dig);`
223			`end if;`
224
225			`Dig := PP (J) and 16#0F#;`
226
227			`if Dig > 9 then`
228			`raise Constraint_Error;`
229			`else`
230			`V := V * 10 + Integer_32 (Dig);`
231			`end if;`
232
233			`J := J + 1;`
234			`end loop;`
235
236			`-- Deal with digit nibble in sign byte`
237
238			`Dig := Shift_Right (PP (J), 4);`
239
240			`if Dig > 9 then`
241			`raise Constraint_Error;`
242			`else`
243			`V := V * 10 + Integer_32 (Dig);`
244			`end if;`
245
246			`Sign := PP (J) and 16#0F#;`
247
248			`-- Process sign nibble (deal with most common cases first)`
249
250			`if Sign = 16#C# then`
251			`return V;`
252
253			`elsif Sign = 16#D# then`
254			`return -V;`
255
256			`elsif Sign = 16#B# then`
257			`return -V;`
258
259			`elsif Sign >= 16#A# then`
260			`return V;`
261
262			`else`
263			`raise Constraint_Error;`
264			`end if;`
265			`end Packed_To_Int32;`
266
267			`---------------------`
268			`-- Packed_To_Int64 --`
269			`---------------------`
270
271			`function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is`
272			`PP : constant Packed_Ptr := To_Packed_Ptr (P);`
273			`Empty_Nibble : constant Boolean := ((D mod 2) = 0);`
274			`B : constant Byte_Length := (D / 2) + 1;`
275			`V : Integer_64;`
276			`Dig : Unsigned_8;`
277			`Sign : Unsigned_8;`
278			`J : Positive;`
279
280			`begin`
281			`-- Cases where there is an unused (zero) nibble in the first byte.`
282			`-- Deal with the single digit nibble at the right of this byte`
283
284			`if Empty_Nibble then`
285			`V := Integer_64 (PP (1));`
286			`J := 2;`
287
288			`if V > 9 then`
289			`raise Constraint_Error;`
290			`end if;`
291
292			`-- Cases where all nibbles are used`
293
294			`else`
295			`J := 1;`
296			`V := 0;`
297			`end if;`
298
299			`-- Loop to process bytes containing two digit nibbles`
300
301			`while J < B loop`
302			`Dig := Shift_Right (PP (J), 4);`
303
304			`if Dig > 9 then`
305			`raise Constraint_Error;`
306			`else`
307			`V := V * 10 + Integer_64 (Dig);`
308			`end if;`
309
310			`Dig := PP (J) and 16#0F#;`
311
312			`if Dig > 9 then`
313			`raise Constraint_Error;`
314			`else`
315			`V := V * 10 + Integer_64 (Dig);`
316			`end if;`
317
318			`J := J + 1;`
319			`end loop;`
320
321			`-- Deal with digit nibble in sign byte`
322
323			`Dig := Shift_Right (PP (J), 4);`
324
325			`if Dig > 9 then`
326			`raise Constraint_Error;`
327			`else`
328			`V := V * 10 + Integer_64 (Dig);`
329			`end if;`
330
331			`Sign := PP (J) and 16#0F#;`
332
333			`-- Process sign nibble (deal with most common cases first)`
334
335			`if Sign = 16#C# then`
336			`return V;`
337
338			`elsif Sign = 16#D# then`
339			`return -V;`
340
341			`elsif Sign = 16#B# then`
342			`return -V;`
343
344			`elsif Sign >= 16#A# then`
345			`return V;`
346
347			`else`
348			`raise Constraint_Error;`
349			`end if;`
350			`end Packed_To_Int64;`
351
352			`end Interfaces.Packed_Decimal;`