gcc/ada/i-pacdec.adb

   1 ------------------------------------------------------------------------------
   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-2007, 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 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.                                              --
  22 --                                                                          --
  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.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with System; use System;
  36
  37 with Ada.Unchecked_Conversion;
  38
  39 package body Interfaces.Packed_Decimal is
  40
  41    type Packed is array (Byte_Length) of Unsigned_8;
  42    --  The type used internally to represent packed decimal
  43
  44    type Packed_Ptr is access Packed;
  45    function To_Packed_Ptr is
  46      new Ada.Unchecked_Conversion (Address, Packed_Ptr);
  47
  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.
  51
  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#);
  73
  74    ---------------------
  75    -- Int32_To_Packed --
  76    ---------------------
  77
  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;
  82       VV           : Integer_32 := V;
  83
  84    begin
  85       --  Deal with sign byte first
  86
  87       if VV >= 0 then
  88          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
  89          VV := VV / 10;
  90
  91       else
  92          VV := -VV;
  93          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
  94       end if;
  95
  96       for J in reverse B - 1 .. 2 loop
  97          if VV = 0 then
  98             for K in 1 .. J loop
  99                PP (K) := 16#00#;
 100             end loop;
 101
 102             return;
 103
 104          else
 105             PP (J) := Packed_Byte (Integer (VV rem 100));
 106             VV := VV / 100;
 107          end if;
 108       end loop;
 109
 110       --  Deal with leading byte
 111
 112       if Empty_Nibble then
 113          if VV > 9 then
 114             raise Constraint_Error;
 115          else
 116             PP (1) := Unsigned_8 (VV);
 117          end if;
 118
 119       else
 120          if VV > 99 then
 121             raise Constraint_Error;
 122          else
 123             PP (1) := Packed_Byte (Integer (VV));
 124          end if;
 125       end if;
 126
 127    end Int32_To_Packed;
 128
 129    ---------------------
 130    -- Int64_To_Packed --
 131    ---------------------
 132
 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;
 138
 139    begin
 140       --  Deal with sign byte first
 141
 142       if VV >= 0 then
 143          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
 144          VV := VV / 10;
 145
 146       else
 147          VV := -VV;
 148          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
 149       end if;
 150
 151       for J in reverse B - 1 .. 2 loop
 152          if VV = 0 then
 153             for K in 1 .. J loop
 154                PP (K) := 16#00#;
 155             end loop;
 156
 157             return;
 158
 159          else
 160             PP (J) := Packed_Byte (Integer (VV rem 100));
 161             VV := VV / 100;
 162          end if;
 163       end loop;
 164
 165       --  Deal with leading byte
 166
 167       if Empty_Nibble then
 168          if VV > 9 then
 169             raise Constraint_Error;
 170          else
 171             PP (1) := Unsigned_8 (VV);
 172          end if;
 173
 174       else
 175          if VV > 99 then
 176             raise Constraint_Error;
 177          else
 178             PP (1) := Packed_Byte (Integer (VV));
 179          end if;
 180       end if;
 181
 182    end Int64_To_Packed;
 183
 184    ---------------------
 185    -- Packed_To_Int32 --
 186    ---------------------
 187
 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;
 192       V            : Integer_32;
 193       Dig          : Unsigned_8;
 194       Sign         : Unsigned_8;
 195       J            : Positive;
 196
 197    begin
 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
 200
 201       if Empty_Nibble then
 202          V := Integer_32 (PP (1));
 203          J := 2;
 204
 205          if V > 9 then
 206             raise Constraint_Error;
 207          end if;
 208
 209       --  Cases where all nibbles are used
 210
 211       else
 212          V := 0;
 213          J := 1;
 214       end if;
 215
 216       --  Loop to process bytes containing two digit nibbles
 217
 218       while J < B loop
 219          Dig := Shift_Right (PP (J), 4);
 220
 221          if Dig > 9 then
 222             raise Constraint_Error;
 223          else
 224             V := V * 10 + Integer_32 (Dig);
 225          end if;
 226
 227          Dig := PP (J) and 16#0F#;
 228
 229          if Dig > 9 then
 230             raise Constraint_Error;
 231          else
 232             V := V * 10 + Integer_32 (Dig);
 233          end if;
 234
 235          J := J + 1;
 236       end loop;
 237
 238       --  Deal with digit nibble in sign byte
 239
 240       Dig := Shift_Right (PP (J), 4);
 241
 242       if Dig > 9 then
 243          raise Constraint_Error;
 244       else
 245          V := V * 10 + Integer_32 (Dig);
 246       end if;
 247
 248       Sign :=  PP (J) and 16#0F#;
 249
 250       --  Process sign nibble (deal with most common cases first)
 251
 252       if Sign = 16#C# then
 253          return V;
 254
 255       elsif Sign = 16#D# then
 256          return -V;
 257
 258       elsif Sign = 16#B# then
 259          return -V;
 260
 261       elsif Sign >= 16#A# then
 262          return V;
 263
 264       else
 265          raise Constraint_Error;
 266       end if;
 267    end Packed_To_Int32;
 268
 269    ---------------------
 270    -- Packed_To_Int64 --
 271    ---------------------
 272
 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;
 277       V            : Integer_64;
 278       Dig          : Unsigned_8;
 279       Sign         : Unsigned_8;
 280       J            : Positive;
 281
 282    begin
 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
 285
 286       if Empty_Nibble then
 287          V := Integer_64 (PP (1));
 288          J := 2;
 289
 290          if V > 9 then
 291             raise Constraint_Error;
 292          end if;
 293
 294       --  Cases where all nibbles are used
 295
 296       else
 297          J := 1;
 298          V := 0;
 299       end if;
 300
 301       --  Loop to process bytes containing two digit nibbles
 302
 303       while J < B loop
 304          Dig := Shift_Right (PP (J), 4);
 305
 306          if Dig > 9 then
 307             raise Constraint_Error;
 308          else
 309             V := V * 10 + Integer_64 (Dig);
 310          end if;
 311
 312          Dig := PP (J) and 16#0F#;
 313
 314          if Dig > 9 then
 315             raise Constraint_Error;
 316          else
 317             V := V * 10 + Integer_64 (Dig);
 318          end if;
 319
 320          J := J + 1;
 321       end loop;
 322
 323       --  Deal with digit nibble in sign byte
 324
 325       Dig := Shift_Right (PP (J), 4);
 326
 327       if Dig > 9 then
 328          raise Constraint_Error;
 329       else
 330          V := V * 10 + Integer_64 (Dig);
 331       end if;
 332
 333       Sign :=  PP (J) and 16#0F#;
 334
 335       --  Process sign nibble (deal with most common cases first)
 336
 337       if Sign = 16#C# then
 338          return V;
 339
 340       elsif Sign = 16#D# then
 341          return -V;
 342
 343       elsif Sign = 16#B# then
 344          return -V;
 345
 346       elsif Sign >= 16#A# then
 347          return V;
 348
 349       else
 350          raise Constraint_Error;
 351       end if;
 352    end Packed_To_Int64;
 353
 354 end Interfaces.Packed_Decimal;