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 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with System;                  use System;
  37 with 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 new Unchecked_Conversion (Address, Packed_Ptr);
  46
  47    --  The following array is used to convert a value in the range 0-99 to
  48    --  a packed decimal format with two hexadecimal nibbles. It is worth
  49    --  using table look up in this direction because divides are expensive.
  50
  51    Packed_Byte : constant array (00 .. 99) of Unsigned_8 :=
  52       (16#00#, 16#01#, 16#02#, 16#03#, 16#04#,
  53        16#05#, 16#06#, 16#07#, 16#08#, 16#09#,
  54        16#10#, 16#11#, 16#12#, 16#13#, 16#14#,
  55        16#15#, 16#16#, 16#17#, 16#18#, 16#19#,
  56        16#20#, 16#21#, 16#22#, 16#23#, 16#24#,
  57        16#25#, 16#26#, 16#27#, 16#28#, 16#29#,
  58        16#30#, 16#31#, 16#32#, 16#33#, 16#34#,
  59        16#35#, 16#36#, 16#37#, 16#38#, 16#39#,
  60        16#40#, 16#41#, 16#42#, 16#43#, 16#44#,
  61        16#45#, 16#46#, 16#47#, 16#48#, 16#49#,
  62        16#50#, 16#51#, 16#52#, 16#53#, 16#54#,
  63        16#55#, 16#56#, 16#57#, 16#58#, 16#59#,
  64        16#60#, 16#61#, 16#62#, 16#63#, 16#64#,
  65        16#65#, 16#66#, 16#67#, 16#68#, 16#69#,
  66        16#70#, 16#71#, 16#72#, 16#73#, 16#74#,
  67        16#75#, 16#76#, 16#77#, 16#78#, 16#79#,
  68        16#80#, 16#81#, 16#82#, 16#83#, 16#84#,
  69        16#85#, 16#86#, 16#87#, 16#88#, 16#89#,
  70        16#90#, 16#91#, 16#92#, 16#93#, 16#94#,
  71        16#95#, 16#96#, 16#97#, 16#98#, 16#99#);
  72
  73    ---------------------
  74    -- Int32_To_Packed --
  75    ---------------------
  76
  77    procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is
  78       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  79       Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
  80       B            : constant Byte_Length := (D / 2) + 1;
  81       VV           : Integer_32 := V;
  82
  83    begin
  84       --  Deal with sign byte first
  85
  86       if VV >= 0 then
  87          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
  88          VV := VV / 10;
  89
  90       else
  91          VV := -VV;
  92          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
  93       end if;
  94
  95       for J in reverse B - 1 .. 2 loop
  96          if VV = 0 then
  97             for K in 1 .. J loop
  98                PP (K) := 16#00#;
  99             end loop;
 100
 101             return;
 102
 103          else
 104             PP (J) := Packed_Byte (Integer (VV rem 100));
 105             VV := VV / 100;
 106          end if;
 107       end loop;
 108
 109       --  Deal with leading byte
 110
 111       if Empty_Nibble then
 112          if VV > 9 then
 113             raise Constraint_Error;
 114          else
 115             PP (1) := Unsigned_8 (VV);
 116          end if;
 117
 118       else
 119          if VV > 99 then
 120             raise Constraint_Error;
 121          else
 122             PP (1) := Packed_Byte (Integer (VV));
 123          end if;
 124       end if;
 125
 126    end Int32_To_Packed;
 127
 128    ---------------------
 129    -- Int64_To_Packed --
 130    ---------------------
 131
 132    procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is
 133       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
 134       Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
 135       B            : constant Byte_Length := (D / 2) + 1;
 136       VV           : Integer_64 := V;
 137
 138    begin
 139       --  Deal with sign byte first
 140
 141       if VV >= 0 then
 142          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
 143          VV := VV / 10;
 144
 145       else
 146          VV := -VV;
 147          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
 148       end if;
 149
 150       for J in reverse B - 1 .. 2 loop
 151          if VV = 0 then
 152             for K in 1 .. J loop
 153                PP (K) := 16#00#;
 154             end loop;
 155
 156             return;
 157
 158          else
 159             PP (J) := Packed_Byte (Integer (VV rem 100));
 160             VV := VV / 100;
 161          end if;
 162       end loop;
 163
 164       --  Deal with leading byte
 165
 166       if Empty_Nibble then
 167          if VV > 9 then
 168             raise Constraint_Error;
 169          else
 170             PP (1) := Unsigned_8 (VV);
 171          end if;
 172
 173       else
 174          if VV > 99 then
 175             raise Constraint_Error;
 176          else
 177             PP (1) := Packed_Byte (Integer (VV));
 178          end if;
 179       end if;
 180
 181    end Int64_To_Packed;
 182
 183    ---------------------
 184    -- Packed_To_Int32 --
 185    ---------------------
 186
 187    function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is
 188       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
 189       Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
 190       B            : constant Byte_Length := (D / 2) + 1;
 191       V            : Integer_32;
 192       Dig          : Unsigned_8;
 193       Sign         : Unsigned_8;
 194       J            : Positive;
 195
 196    begin
 197       --  Cases where there is an unused (zero) nibble in the first byte.
 198       --  Deal with the single digit nibble at the right of this byte
 199
 200       if Empty_Nibble then
 201          V := Integer_32 (PP (1));
 202          J := 2;
 203
 204          if V > 9 then
 205             raise Constraint_Error;
 206          end if;
 207
 208       --  Cases where all nibbles are used
 209
 210       else
 211          V := 0;
 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          V := 0;
 298       end if;
 299
 300       --  Loop to process bytes containing two digit nibbles
 301
 302       while J < B loop
 303          Dig := Shift_Right (PP (J), 4);
 304
 305          if Dig > 9 then
 306             raise Constraint_Error;
 307          else
 308             V := V * 10 + Integer_64 (Dig);
 309          end if;
 310
 311          Dig := PP (J) and 16#0F#;
 312
 313          if Dig > 9 then
 314             raise Constraint_Error;
 315          else
 316             V := V * 10 + Integer_64 (Dig);
 317          end if;
 318
 319          J := J + 1;
 320       end loop;
 321
 322       --  Deal with digit nibble in sign byte
 323
 324       Dig := Shift_Right (PP (J), 4);
 325
 326       if Dig > 9 then
 327          raise Constraint_Error;
 328       else
 329          V := V * 10 + Integer_64 (Dig);
 330       end if;
 331
 332       Sign :=  PP (J) and 16#0F#;
 333
 334       --  Process sign nibble (deal with most common cases first)
 335
 336       if Sign = 16#C# then
 337          return V;
 338
 339       elsif Sign = 16#D# then
 340          return -V;
 341
 342       elsif Sign = 16#B# then
 343          return -V;
 344
 345       elsif Sign >= 16#A# then
 346          return V;
 347
 348       else
 349          raise Constraint_Error;
 350       end if;
 351    end Packed_To_Int64;
 352
 353 end Interfaces.Packed_Decimal;