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 / s-imgdec.adb < prev    next >
Text File  |  1996-09-28  |  11KB  |  352 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                        S Y S T E M . I M G _ D E C                       --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.6 $                              --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Img_Int; use System.Img_Int;
  27.  
  28. package body System.Img_Dec is
  29.  
  30.    -------------------
  31.    -- Image_Decimal --
  32.    -------------------
  33.  
  34.    function Image_Decimal
  35.      (V     : Integer;
  36.       Scale : Integer)
  37.       return  String
  38.    is
  39.       P : Natural := 0;
  40.       S : String (1 .. 64);
  41.  
  42.    begin
  43.       Set_Image_Decimal (V, S, P, Scale, 2, Integer'Max (1, Scale), 0);
  44.       return S (1 .. P);
  45.    end Image_Decimal;
  46.  
  47.    -----------------------
  48.    -- Set_Image_Decimal --
  49.    -----------------------
  50.  
  51.    procedure Set_Image_Decimal
  52.      (V     : Integer;
  53.       S     : out String;
  54.       P     : in out Natural;
  55.       Scale : Integer;
  56.       Fore  : Natural;
  57.       Aft   : Natural;
  58.       Exp   : Natural)
  59.    is
  60.       Digs : String := Image_Integer (V);
  61.       --  Sign and digits of decimal value
  62.  
  63.       D : Natural;
  64.       --  Number of characters in Digs buffer
  65.  
  66.    begin
  67.       Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp);
  68.    end Set_Image_Decimal;
  69.  
  70.    ------------------------
  71.    -- Set_Decimal_Digits --
  72.    ------------------------
  73.  
  74.    procedure Set_Decimal_Digits
  75.      (Digs  : in out String;
  76.       NDigs : Natural;
  77.       S     : out String;
  78.       P     : in out Natural;
  79.       Scale : Integer;
  80.       Fore  : Natural;
  81.       Aft   : Natural;
  82.       Exp   : Natural)
  83.    is
  84.       Minus : constant Boolean := (Digs (1) = '-');
  85.       --  Set True if input is negative
  86.  
  87.       Zero : Boolean := (Digs (2) = '0');
  88.       --  Set True if input is exactly zero (only case when a leading zero
  89.       --  is permitted in the input string given to this procedure). This
  90.       --  flag can get set later if rounding causes the value to become zero.
  91.  
  92.       FD : Natural := 2;
  93.       --  First digit position of digits remaining to be processed
  94.  
  95.       LD : Natural := NDigs;
  96.       --  Last digit position of digits remaining to be processed
  97.  
  98.       ND : Natural := NDigs - 1;
  99.       --  Number of digits remaining to be processed (LD - FD + 1)
  100.  
  101.       Digits_Before_Point : Integer := ND - Scale;
  102.       --  Number of digits before decimal point in the input value. This
  103.       --  value can be negative if the input value is less than 0.1, so
  104.       --  it is an indication of the current exponent. Digits_Before_Point
  105.       --  is adjusted if the rounding step generates an extra digit.
  106.  
  107.       After : constant Natural := Integer'Max (1, Aft);
  108.       --  Digit positions after decimal point in result string
  109.  
  110.       Expon : Integer;
  111.       --  Integer value of exponent
  112.  
  113.       RP : Integer;
  114.       --  Position for rounding in no exponent case
  115.  
  116.       procedure Round (N : Natural);
  117.       --  Round the number in Digs. N is the position of the last digit to be
  118.       --  retained in the rounded position (rounding is based on Digs (N + 1)
  119.       --  FD, LD, ND are reset as necessary if required. Note that if the
  120.       --  result value rounds up (e.g. 9.99 => 10.0), an extra digit can be
  121.       --  placed in the sign position as a result of the rounding, this is
  122.       --  the case in which FD is adjusted.
  123.  
  124.       procedure Set (C : Character);
  125.       pragma Inline (Set);
  126.       --  Sets character C in output buffer
  127.  
  128.       procedure Set_Blanks_And_Sign (N : Integer);
  129.       --  Sets leading blanks and minus sign if needed. N is the number of
  130.       --  positions to be filled (a minus sign is output even if N is zero
  131.       --  or negative, but for a positive value, if N is non-positive, then
  132.       --  the call has no effect).
  133.  
  134.       procedure Set_Digits (S, E : Natural);
  135.       pragma Inline (Set_Digits);
  136.       --  Set digits S through E from Digs, no effect if S > E
  137.  
  138.       procedure Set_Zeroes (N : Integer);
  139.       pragma Inline (Set_Zeroes);
  140.       --  Set N zeroes, no effect if N is negative
  141.  
  142.       procedure Round (N : Natural) is
  143.          D : Character;
  144.  
  145.       begin
  146.          --  Nothing to do if rounding at or past last digit
  147.  
  148.          if N >= LD then
  149.             return;
  150.  
  151.          --  Cases of rounding before the initial digit
  152.  
  153.          elsif N < FD then
  154.  
  155.             --  The result is zero, unless we are rounding just before
  156.             --  the first digit, and the first digit is five or more.
  157.  
  158.             if N = 1 and then Digs (2) >= '5' then
  159.                Digs (1) := '1';
  160.             else
  161.                Digs (1) := '0';
  162.                Zero := True;
  163.             end if;
  164.  
  165.             Digits_Before_Point := Digits_Before_Point + 1;
  166.             FD := 1;
  167.             LD := 1;
  168.             ND := 1;
  169.  
  170.          --  Normal case of rounding an existing digit
  171.  
  172.          else
  173.             LD := N;
  174.             ND := LD - 1;
  175.  
  176.             if Digs (N + 1) >= '5' then
  177.                for J in reverse 2 .. N loop
  178.                   D := Character'Succ (Digs (J));
  179.  
  180.                   if D <= '9' then
  181.                      Digs (J) := D;
  182.                      return;
  183.                   else
  184.                      Digs (J) := '0';
  185.                   end if;
  186.                end loop;
  187.  
  188.                --  Here the rounding overflows into the sign position. That's
  189.                --  OK, because we already captured the value of the sign and
  190.                --  we are in any case destroying the value in the Digs buffer
  191.  
  192.                Digs (1) := '1';
  193.                FD := 1;
  194.                ND := ND + 1;
  195.                Digits_Before_Point := Digits_Before_Point + 1;
  196.             end if;
  197.          end if;
  198.       end Round;
  199.  
  200.       procedure Set (C : Character) is
  201.       begin
  202.          P := P + 1;
  203.          S (P) := C;
  204.       end Set;
  205.  
  206.       procedure Set_Blanks_And_Sign (N : Integer) is
  207.          W : Integer := N;
  208.  
  209.       begin
  210.          if Minus then
  211.             W := W - 1;
  212.             Set ('-');
  213.          end if;
  214.  
  215.          for J in 1 .. W loop
  216.             Set (' ');
  217.          end loop;
  218.       end Set_Blanks_And_Sign;
  219.  
  220.       procedure Set_Digits (S, E : Natural) is
  221.       begin
  222.          for J in S .. E loop
  223.             Set (Digs (J));
  224.          end loop;
  225.       end Set_Digits;
  226.  
  227.       procedure Set_Zeroes (N : Integer) is
  228.       begin
  229.          for J in 1 .. N loop
  230.             Set ('0');
  231.          end loop;
  232.       end Set_Zeroes;
  233.  
  234.    --  Start of processing for Set_Decimal_Digits
  235.  
  236.    begin
  237.       --  Case of exponent given
  238.  
  239.       if Exp > 0 then
  240.          Set_Blanks_And_Sign (Fore - 1);
  241.          Round (Aft + 2);
  242.          Set (Digs (FD));
  243.          FD := FD + 1;
  244.          ND := ND - 1;
  245.          Set ('.');
  246.  
  247.          if ND >= After then
  248.             Set_Digits (FD, FD + After - 1);
  249.  
  250.          else
  251.             Set_Digits (FD, LD);
  252.             Set_Zeroes (After - ND);
  253.          end if;
  254.  
  255.          --  Calculate exponent. The number of digits before the decimal point
  256.          --  in the input is Digits_Before_Point, and the number of digits
  257.          --  before the decimal point in the output is 1, so we can get the
  258.          --  exponent as the difference between these two values. The one
  259.          --  exception is for the value zero, which by convention has an
  260.          --  exponent of +0.
  261.  
  262.          if Zero then
  263.             Expon := 0;
  264.          else
  265.             Expon := Digits_Before_Point - 1;
  266.          end if;
  267.  
  268.          Set ('E');
  269.          ND := 0;
  270.  
  271.          if Expon >= 0 then
  272.             Set ('+');
  273.             Set_Image_Integer (Expon, Digs, ND);
  274.          else
  275.             Set ('-');
  276.             Set_Image_Integer (-Expon, Digs, ND);
  277.          end if;
  278.  
  279.          Set_Zeroes (Exp - ND - 1);
  280.          Set_Digits (1, ND);
  281.          return;
  282.  
  283.       --  Case of no exponent given. To make these cases clear, we use
  284.       --  examples. For all the examples, we assume Fore = 2, Aft = 3.
  285.       --  A P in the example input string is an implied zero position,
  286.       --  not included in the input string.
  287.  
  288.       else
  289.          --  Round at correct position
  290.          --    Input: 4PP      => unchanged
  291.          --    Input: 400.03   => unchanged
  292.          --    Input  3.4567   => 3.457
  293.          --    Input: 9.9999   => 10.000
  294.          --    Input: 0.PPP5   => 0.PP1
  295.          --    Input: 0.PPP4   => 0
  296.          --    Input: 0.00003  => 0
  297.  
  298.          Round (LD - (Scale - After));
  299.  
  300.          --  No digits before point in input
  301.          --    Input: .123   Output: 0.123
  302.          --    Input: .PP3   Output: 0.003
  303.  
  304.          if Digits_Before_Point <= 0 then
  305.             Set_Blanks_And_Sign (Fore - 1);
  306.             Set ('0');
  307.             Set ('.');
  308.  
  309.             Set_Zeroes (After - ND);
  310.             Set_Digits (FD, LD);
  311.  
  312.          --  At least one digit before point in input
  313.  
  314.          else
  315.             Set_Blanks_And_Sign (Fore - Digits_Before_Point);
  316.  
  317.             --  Less digits in input than are needed before point
  318.             --    Input: 1PP  Output: 100.000
  319.  
  320.             if FD + Digits_Before_Point - 1 > LD then
  321.                Set_Digits (FD, LD);
  322.                Set_Zeroes (FD + Digits_Before_Point - 1 - LD);
  323.                Set ('0');
  324.                Set_Zeroes (After);
  325.  
  326.             --  Input has full amount of digits before decimal point
  327.  
  328.             else
  329.                Set_Digits (FD, FD + Digits_Before_Point - 1);
  330.                Set ('.');
  331.  
  332.                --  Input does not have full amount of digits after point
  333.                --    Input: 123.4  Output: 123.400
  334.  
  335.                if LD < FD + Digits_Before_Point then
  336.                   Set_Digits (FD + Digits_Before_Point, LD);
  337.                   Set_Zeroes (FD + Digits_Before_Point - LD);
  338.  
  339.                --  Input has full amount of digits before and after point
  340.                --    Input: 123.345  Output: 123.345
  341.  
  342.                else
  343.                   Set_Digits (FD + Digits_Before_Point, LD);
  344.                end if;
  345.             end if;
  346.          end if;
  347.       end if;
  348.  
  349.    end Set_Decimal_Digits;
  350.  
  351. end System.Img_Dec;
  352.