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 --                            $Revision: 1.1 $
  11 --                                                                          --
  12 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  13 --                                                                          --
  14 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  15 -- terms of the  GNU General Public License as published  by the Free Soft- --
  16 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  17 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  18 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  19 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  20 -- for  more details.  You should have  received  a copy of the GNU General --
  21 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  22 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  23 -- MA 02111-1307, USA.                                                      --
  24 --                                                                          --
  25 -- As a special exception,  if other files  instantiate  generics from this --
  26 -- unit, or you link  this unit with other files  to produce an executable, --
  27 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  28 -- covered  by the  GNU  General  Public  License.  This exception does not --
  29 -- however invalidate  any other reasons why  the executable file  might be --
  30 -- covered by the  GNU Public License.                                      --
  31 --                                                                          --
  32 -- GNAT was originally developed  by the GNAT team at  New York University. --
  33 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 with System;                  use System;
  38 with Unchecked_Conversion;
  39
  40 package body Interfaces.Packed_Decimal is
  41
  42    type Packed is array (Byte_Length) of Unsigned_8;
  43    --  The type used internally to represent packed decimal
  44
  45    type Packed_Ptr is access Packed;
  46    function To_Packed_Ptr is new 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          J := 1;
 213       end if;
 214
 215       --  Loop to process bytes containing two digit nibbles
 216
 217       while J < B loop
 218          Dig := Shift_Right (PP (J), 4);
 219
 220          if Dig > 9 then
 221             raise Constraint_Error;
 222          else
 223             V := V * 10 + Integer_32 (Dig);
 224          end if;
 225
 226          Dig := PP (J) and 16#0F#;
 227
 228          if Dig > 9 then
 229             raise Constraint_Error;
 230          else
 231             V := V * 10 + Integer_32 (Dig);
 232          end if;
 233
 234          J := J + 1;
 235       end loop;
 236
 237       --  Deal with digit nibble in sign byte
 238
 239       Dig := Shift_Right (PP (J), 4);
 240
 241       if Dig > 9 then
 242          raise Constraint_Error;
 243       else
 244          V := V * 10 + Integer_32 (Dig);
 245       end if;
 246
 247       Sign :=  PP (J) and 16#0F#;
 248
 249       --  Process sign nibble (deal with most common cases first)
 250
 251       if Sign = 16#C# then
 252          return V;
 253
 254       elsif Sign = 16#D# then
 255          return -V;
 256
 257       elsif Sign = 16#B# then
 258          return -V;
 259
 260       elsif Sign >= 16#A# then
 261          return V;
 262
 263       else
 264          raise Constraint_Error;
 265       end if;
 266    end Packed_To_Int32;
 267
 268    ---------------------
 269    -- Packed_To_Int64 --
 270    ---------------------
 271
 272    function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is
 273       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
 274       Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
 275       B            : constant Byte_Length := (D / 2) + 1;
 276       V            : Integer_64;
 277       Dig          : Unsigned_8;
 278       Sign         : Unsigned_8;
 279       J            : Positive;
 280
 281    begin
 282       --  Cases where there is an unused (zero) nibble in the first byte.
 283       --  Deal with the single digit nibble at the right of this byte
 284
 285       if Empty_Nibble then
 286          V := Integer_64 (PP (1));
 287          J := 2;
 288
 289          if V > 9 then
 290             raise Constraint_Error;
 291          end if;
 292
 293       --  Cases where all nibbles are used
 294
 295       else
 296          J := 1;
 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;