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-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;