home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / i-pacdec.adb < prev    next >
Text File  |  1996-09-28  |  10KB  |  342 lines
  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.2 $                              --
  11. --                                                                          --
  12. -- The GNAT library is free software; you can redistribute it and/or modify --
  13. -- it under terms of the GNU Library General Public License as published by --
  14. -- the Free Software  Foundation; either version 2, or (at your option) any --
  15. -- later version.  The GNAT library is distributed in the hope that it will --
  16. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  17. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  18. -- Library  General  Public  License for  more  details.  You  should  have --
  19. -- received  a copy of the GNU  Library  General Public License  along with --
  20. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  21. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with System;                  use System;
  26. with System.Storage_Elements; use System.Storage_Elements;
  27. with Unchecked_Conversion;
  28.  
  29. package body Interfaces.Packed_Decimal is
  30.  
  31.    type Packed is array (Byte_Length) of Unsigned_8;
  32.    --  The type used internally to represent packed decimal
  33.  
  34.    type Packed_Ptr is access Packed;
  35.    function To_Packed_Ptr is new Unchecked_Conversion (Address, Packed_Ptr);
  36.  
  37.    --  The following array is used to convert a value in the range 0-99 to
  38.    --  a packed decimal format with two hexadecimal nibbles. It is worth
  39.    --  using table look up in this direction because divides are expensive.
  40.  
  41.    Packed_Byte : constant array (00 .. 99) of Unsigned_8 :=
  42.       (16#00#, 16#01#, 16#02#, 16#03#, 16#04#,
  43.        16#05#, 16#06#, 16#07#, 16#08#, 16#09#,
  44.        16#10#, 16#11#, 16#12#, 16#13#, 16#14#,
  45.        16#15#, 16#16#, 16#17#, 16#18#, 16#19#,
  46.        16#20#, 16#21#, 16#22#, 16#23#, 16#24#,
  47.        16#25#, 16#26#, 16#27#, 16#28#, 16#29#,
  48.        16#30#, 16#31#, 16#32#, 16#33#, 16#34#,
  49.        16#35#, 16#36#, 16#37#, 16#38#, 16#39#,
  50.        16#40#, 16#41#, 16#42#, 16#43#, 16#44#,
  51.        16#45#, 16#46#, 16#47#, 16#48#, 16#49#,
  52.        16#50#, 16#51#, 16#52#, 16#53#, 16#54#,
  53.        16#55#, 16#56#, 16#57#, 16#58#, 16#59#,
  54.        16#60#, 16#61#, 16#62#, 16#63#, 16#64#,
  55.        16#65#, 16#66#, 16#67#, 16#68#, 16#69#,
  56.        16#70#, 16#71#, 16#72#, 16#73#, 16#74#,
  57.        16#75#, 16#76#, 16#77#, 16#78#, 16#79#,
  58.        16#80#, 16#81#, 16#82#, 16#83#, 16#84#,
  59.        16#85#, 16#86#, 16#87#, 16#88#, 16#89#,
  60.        16#90#, 16#91#, 16#92#, 16#93#, 16#94#,
  61.        16#95#, 16#96#, 16#97#, 16#98#, 16#99#);
  62.  
  63.    ---------------------
  64.    -- Packed_To_Int32 --
  65.    ---------------------
  66.  
  67.    function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is
  68.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  69.       Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
  70.       B            : constant Byte_Length := (D / 2) + 1;
  71.       V            : Integer_32;
  72.       Dig          : Unsigned_8;
  73.       Sign         : Unsigned_8;
  74.       J            : Positive;
  75.  
  76.    begin
  77.       --  Cases where there is an unused (zero) nibble in the first byte.
  78.       --  Deal with the single digit nibble at the right of this byte
  79.  
  80.       if Empty_Nibble then
  81.          V := Integer_32 (PP (1));
  82.          J := 2;
  83.  
  84.          if V > 9 then
  85.             raise Constraint_Error;
  86.          end if;
  87.  
  88.       --  Cases where all nibbles are used
  89.  
  90.       else
  91.          J := 1;
  92.       end if;
  93.  
  94.       --  Loop to process bytes containing two digit nibbles
  95.  
  96.       while J < B loop
  97.          Dig := Shift_Right (PP (J), 4);
  98.  
  99.          if Dig > 9 then
  100.             raise Constraint_Error;
  101.          else
  102.             V := V * 10 + Integer_32 (Dig);
  103.          end if;
  104.  
  105.          Dig := PP (J) and 16#0F#;
  106.  
  107.          if Dig > 9 then
  108.             raise Constraint_Error;
  109.          else
  110.             V := V * 10 + Integer_32 (Dig);
  111.          end if;
  112.  
  113.          J := J + 1;
  114.       end loop;
  115.  
  116.       --  Deal with digit nibble in sign byte
  117.  
  118.       Dig := Shift_Right (PP (J), 4);
  119.  
  120.       if Dig > 9 then
  121.          raise Constraint_Error;
  122.       else
  123.          V := V * 10 + Integer_32 (Dig);
  124.       end if;
  125.  
  126.       Sign :=  PP (J) and 16#0F#;
  127.  
  128.       --  Process sign nibble (deal with most common cases first)
  129.  
  130.       if Sign = 16#C# then
  131.          return V;
  132.  
  133.       elsif Sign = 16#D# then
  134.          return -V;
  135.  
  136.       elsif Sign = 16#B# then
  137.          return -V;
  138.  
  139.       elsif Sign >= 16#A# then
  140.          return V;
  141.  
  142.       else
  143.          raise Constraint_Error;
  144.       end if;
  145.    end Packed_To_Int32;
  146.  
  147.    ---------------------
  148.    -- Packed_To_Int64 --
  149.    ---------------------
  150.  
  151.    function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is
  152.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  153.       Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
  154.       B            : constant Byte_Length := (D / 2) + 1;
  155.       V            : Integer_64;
  156.       Dig          : Unsigned_8;
  157.       Sign         : Unsigned_8;
  158.       J            : Positive;
  159.  
  160.    begin
  161.       --  Cases where there is an unused (zero) nibble in the first byte.
  162.       --  Deal with the single digit nibble at the right of this byte
  163.  
  164.       if Empty_Nibble then
  165.          V := Integer_64 (PP (1));
  166.          J := 2;
  167.  
  168.          if V > 9 then
  169.             raise Constraint_Error;
  170.          end if;
  171.  
  172.       --  Cases where all nibbles are used
  173.  
  174.       else
  175.          J := 1;
  176.       end if;
  177.  
  178.       --  Loop to process bytes containing two digit nibbles
  179.  
  180.       while J < B loop
  181.          Dig := Shift_Right (PP (J), 4);
  182.  
  183.          if Dig > 9 then
  184.             raise Constraint_Error;
  185.          else
  186.             V := V * 10 + Integer_64 (Dig);
  187.          end if;
  188.  
  189.          Dig := PP (J) and 16#0F#;
  190.  
  191.          if Dig > 9 then
  192.             raise Constraint_Error;
  193.          else
  194.             V := V * 10 + Integer_64 (Dig);
  195.          end if;
  196.  
  197.          J := J + 1;
  198.       end loop;
  199.  
  200.       --  Deal with digit nibble in sign byte
  201.  
  202.       Dig := Shift_Right (PP (J), 4);
  203.  
  204.       if Dig > 9 then
  205.          raise Constraint_Error;
  206.       else
  207.          V := V * 10 + Integer_64 (Dig);
  208.       end if;
  209.  
  210.       Sign :=  PP (J) and 16#0F#;
  211.  
  212.       --  Process sign nibble (deal with most common cases first)
  213.  
  214.       if Sign = 16#C# then
  215.          return V;
  216.  
  217.       elsif Sign = 16#D# then
  218.          return -V;
  219.  
  220.       elsif Sign = 16#B# then
  221.          return -V;
  222.  
  223.       elsif Sign >= 16#A# then
  224.          return V;
  225.  
  226.       else
  227.          raise Constraint_Error;
  228.       end if;
  229.    end Packed_To_Int64;
  230.  
  231.    ---------------------
  232.    -- Int32_To_Packed --
  233.    ---------------------
  234.  
  235.    procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is
  236.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  237.       Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
  238.       B            : constant Byte_Length := (D / 2) + 1;
  239.       VV           : Integer_32 := V;
  240.  
  241.    begin
  242.       --  Deal with sign byte first
  243.  
  244.       if VV >= 0 then
  245.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
  246.          VV := VV / 10;
  247.  
  248.       else
  249.          VV := -VV;
  250.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
  251.       end if;
  252.  
  253.       for J in reverse B - 1 .. 2 loop
  254.          if VV = 0 then
  255.             for K in 1 .. J loop
  256.                PP (K) := 16#00#;
  257.             end loop;
  258.  
  259.             return;
  260.  
  261.          else
  262.             PP (J) := Packed_Byte (Integer (VV rem 100));
  263.             VV := VV / 100;
  264.          end if;
  265.       end loop;
  266.  
  267.       --  Deal with leading byte
  268.  
  269.       if Empty_Nibble then
  270.          if VV > 9 then
  271.             raise Constraint_Error;
  272.          else
  273.             PP (1) := Unsigned_8 (VV);
  274.          end if;
  275.  
  276.       else
  277.          if VV > 99 then
  278.             raise Constraint_Error;
  279.          else
  280.             PP (1) := Packed_Byte (Integer (VV));
  281.          end if;
  282.       end if;
  283.  
  284.    end Int32_To_Packed;
  285.  
  286.    ---------------------
  287.    -- Int64_To_Packed --
  288.    ---------------------
  289.  
  290.    procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is
  291.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  292.       Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
  293.       B            : constant Byte_Length := (D / 2) + 1;
  294.       VV           : Integer_64 := V;
  295.  
  296.    begin
  297.       --  Deal with sign byte first
  298.  
  299.       if VV >= 0 then
  300.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
  301.          VV := VV / 10;
  302.  
  303.       else
  304.          VV := -VV;
  305.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
  306.       end if;
  307.  
  308.       for J in reverse B - 1 .. 2 loop
  309.          if VV = 0 then
  310.             for K in 1 .. J loop
  311.                PP (K) := 16#00#;
  312.             end loop;
  313.  
  314.             return;
  315.  
  316.          else
  317.             PP (J) := Packed_Byte (Integer (VV rem 100));
  318.             VV := VV / 100;
  319.          end if;
  320.       end loop;
  321.  
  322.       --  Deal with leading byte
  323.  
  324.       if Empty_Nibble then
  325.          if VV > 9 then
  326.             raise Constraint_Error;
  327.          else
  328.             PP (1) := Unsigned_8 (VV);
  329.          end if;
  330.  
  331.       else
  332.          if VV > 99 then
  333.             raise Constraint_Error;
  334.          else
  335.             PP (1) := Packed_Byte (Integer (VV));
  336.          end if;
  337.       end if;
  338.  
  339.    end Int64_To_Packed;
  340.  
  341. end Interfaces.Packed_Decimal;
  342.