URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [i-pacdec.adb] - Rev 729
Go to most recent revision | Compare with Previous | Blame | 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;
Go to most recent revision | Compare with Previous | Blame | View Log