home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adav313.zip / gnat-3_13p-os2-bin-20010916.zip / emx / gnatlib / i-pacdec.adb < prev    next >
Text File  |  2000-07-19  |  11KB  |  353 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.5 $                              --
  11. --                                                                          --
  12. --          Copyright (C) 1992-1998, 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. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  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.    -- Packed_To_Int32 --
  76.    ---------------------
  77.  
  78.    function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is
  79.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  80.       Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
  81.       B            : constant Byte_Length := (D / 2) + 1;
  82.       V            : Integer_32;
  83.       Dig          : Unsigned_8;
  84.       Sign         : Unsigned_8;
  85.       J            : Positive;
  86.  
  87.    begin
  88.       --  Cases where there is an unused (zero) nibble in the first byte.
  89.       --  Deal with the single digit nibble at the right of this byte
  90.  
  91.       if Empty_Nibble then
  92.          V := Integer_32 (PP (1));
  93.          J := 2;
  94.  
  95.          if V > 9 then
  96.             raise Constraint_Error;
  97.          end if;
  98.  
  99.       --  Cases where all nibbles are used
  100.  
  101.       else
  102.          J := 1;
  103.       end if;
  104.  
  105.       --  Loop to process bytes containing two digit nibbles
  106.  
  107.       while J < B loop
  108.          Dig := Shift_Right (PP (J), 4);
  109.  
  110.          if Dig > 9 then
  111.             raise Constraint_Error;
  112.          else
  113.             V := V * 10 + Integer_32 (Dig);
  114.          end if;
  115.  
  116.          Dig := PP (J) and 16#0F#;
  117.  
  118.          if Dig > 9 then
  119.             raise Constraint_Error;
  120.          else
  121.             V := V * 10 + Integer_32 (Dig);
  122.          end if;
  123.  
  124.          J := J + 1;
  125.       end loop;
  126.  
  127.       --  Deal with digit nibble in sign byte
  128.  
  129.       Dig := Shift_Right (PP (J), 4);
  130.  
  131.       if Dig > 9 then
  132.          raise Constraint_Error;
  133.       else
  134.          V := V * 10 + Integer_32 (Dig);
  135.       end if;
  136.  
  137.       Sign :=  PP (J) and 16#0F#;
  138.  
  139.       --  Process sign nibble (deal with most common cases first)
  140.  
  141.       if Sign = 16#C# then
  142.          return V;
  143.  
  144.       elsif Sign = 16#D# then
  145.          return -V;
  146.  
  147.       elsif Sign = 16#B# then
  148.          return -V;
  149.  
  150.       elsif Sign >= 16#A# then
  151.          return V;
  152.  
  153.       else
  154.          raise Constraint_Error;
  155.       end if;
  156.    end Packed_To_Int32;
  157.  
  158.    ---------------------
  159.    -- Packed_To_Int64 --
  160.    ---------------------
  161.  
  162.    function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is
  163.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  164.       Empty_Nibble : constant Boolean     := ((D mod 2) = 0);
  165.       B            : constant Byte_Length := (D / 2) + 1;
  166.       V            : Integer_64;
  167.       Dig          : Unsigned_8;
  168.       Sign         : Unsigned_8;
  169.       J            : Positive;
  170.  
  171.    begin
  172.       --  Cases where there is an unused (zero) nibble in the first byte.
  173.       --  Deal with the single digit nibble at the right of this byte
  174.  
  175.       if Empty_Nibble then
  176.          V := Integer_64 (PP (1));
  177.          J := 2;
  178.  
  179.          if V > 9 then
  180.             raise Constraint_Error;
  181.          end if;
  182.  
  183.       --  Cases where all nibbles are used
  184.  
  185.       else
  186.          J := 1;
  187.       end if;
  188.  
  189.       --  Loop to process bytes containing two digit nibbles
  190.  
  191.       while J < B loop
  192.          Dig := Shift_Right (PP (J), 4);
  193.  
  194.          if Dig > 9 then
  195.             raise Constraint_Error;
  196.          else
  197.             V := V * 10 + Integer_64 (Dig);
  198.          end if;
  199.  
  200.          Dig := PP (J) and 16#0F#;
  201.  
  202.          if Dig > 9 then
  203.             raise Constraint_Error;
  204.          else
  205.             V := V * 10 + Integer_64 (Dig);
  206.          end if;
  207.  
  208.          J := J + 1;
  209.       end loop;
  210.  
  211.       --  Deal with digit nibble in sign byte
  212.  
  213.       Dig := Shift_Right (PP (J), 4);
  214.  
  215.       if Dig > 9 then
  216.          raise Constraint_Error;
  217.       else
  218.          V := V * 10 + Integer_64 (Dig);
  219.       end if;
  220.  
  221.       Sign :=  PP (J) and 16#0F#;
  222.  
  223.       --  Process sign nibble (deal with most common cases first)
  224.  
  225.       if Sign = 16#C# then
  226.          return V;
  227.  
  228.       elsif Sign = 16#D# then
  229.          return -V;
  230.  
  231.       elsif Sign = 16#B# then
  232.          return -V;
  233.  
  234.       elsif Sign >= 16#A# then
  235.          return V;
  236.  
  237.       else
  238.          raise Constraint_Error;
  239.       end if;
  240.    end Packed_To_Int64;
  241.  
  242.    ---------------------
  243.    -- Int32_To_Packed --
  244.    ---------------------
  245.  
  246.    procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is
  247.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  248.       Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
  249.       B            : constant Byte_Length := (D / 2) + 1;
  250.       VV           : Integer_32 := V;
  251.  
  252.    begin
  253.       --  Deal with sign byte first
  254.  
  255.       if VV >= 0 then
  256.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
  257.          VV := VV / 10;
  258.  
  259.       else
  260.          VV := -VV;
  261.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
  262.       end if;
  263.  
  264.       for J in reverse B - 1 .. 2 loop
  265.          if VV = 0 then
  266.             for K in 1 .. J loop
  267.                PP (K) := 16#00#;
  268.             end loop;
  269.  
  270.             return;
  271.  
  272.          else
  273.             PP (J) := Packed_Byte (Integer (VV rem 100));
  274.             VV := VV / 100;
  275.          end if;
  276.       end loop;
  277.  
  278.       --  Deal with leading byte
  279.  
  280.       if Empty_Nibble then
  281.          if VV > 9 then
  282.             raise Constraint_Error;
  283.          else
  284.             PP (1) := Unsigned_8 (VV);
  285.          end if;
  286.  
  287.       else
  288.          if VV > 99 then
  289.             raise Constraint_Error;
  290.          else
  291.             PP (1) := Packed_Byte (Integer (VV));
  292.          end if;
  293.       end if;
  294.  
  295.    end Int32_To_Packed;
  296.  
  297.    ---------------------
  298.    -- Int64_To_Packed --
  299.    ---------------------
  300.  
  301.    procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is
  302.       PP           : constant Packed_Ptr  := To_Packed_Ptr (P);
  303.       Empty_Nibble : constant Boolean     := ((D rem 2) = 0);
  304.       B            : constant Byte_Length := (D / 2) + 1;
  305.       VV           : Integer_64 := V;
  306.  
  307.    begin
  308.       --  Deal with sign byte first
  309.  
  310.       if VV >= 0 then
  311.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#;
  312.          VV := VV / 10;
  313.  
  314.       else
  315.          VV := -VV;
  316.          PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#;
  317.       end if;
  318.  
  319.       for J in reverse B - 1 .. 2 loop
  320.          if VV = 0 then
  321.             for K in 1 .. J loop
  322.                PP (K) := 16#00#;
  323.             end loop;
  324.  
  325.             return;
  326.  
  327.          else
  328.             PP (J) := Packed_Byte (Integer (VV rem 100));
  329.             VV := VV / 100;
  330.          end if;
  331.       end loop;
  332.  
  333.       --  Deal with leading byte
  334.  
  335.       if Empty_Nibble then
  336.          if VV > 9 then
  337.             raise Constraint_Error;
  338.          else
  339.             PP (1) := Unsigned_8 (VV);
  340.          end if;
  341.  
  342.       else
  343.          if VV > 99 then
  344.             raise Constraint_Error;
  345.          else
  346.             PP (1) := Packed_Byte (Integer (VV));
  347.          end if;
  348.       end if;
  349.  
  350.    end Int64_To_Packed;
  351.  
  352. end Interfaces.Packed_Decimal;
  353.