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 / a-tiflau.adb < prev    next >
Text File  |  1996-09-28  |  6KB  |  223 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --                A D A . T E X T _ I O . F L O A T _ A U X                 --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.7 $                              --
  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 Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  27.  
  28. with System.Img_Real;  use System.Img_Real;
  29. with System.Val_Real;  use System.Val_Real;
  30.  
  31. package body Ada.Text_IO.Float_Aux is
  32.  
  33.    ---------
  34.    -- Get --
  35.    ---------
  36.  
  37.    procedure Get
  38.      (File  : in File_Type;
  39.       Item  : out Long_Long_Float;
  40.       Width : in Field)
  41.    is
  42.       Buf  : String (1 .. Field'Last);
  43.       Stop : Integer := 0;
  44.       Ptr  : aliased Integer := 1;
  45.  
  46.    begin
  47.       if Width /= 0 then
  48.          Load_Width (File, Width, Buf, Stop);
  49.          String_Skip (Buf, Ptr);
  50.       else
  51.          Load_Real (File, Buf, Stop);
  52.       end if;
  53.  
  54.       Item := Scan_Real (Buf, Ptr'Access, Stop);
  55.  
  56.       Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
  57.    end Get;
  58.  
  59.    ----------
  60.    -- Gets --
  61.    ----------
  62.  
  63.    procedure Gets
  64.      (From : in String;
  65.       Item : out Long_Long_Float;
  66.       Last : out Positive)
  67.    is
  68.       Pos : aliased Integer;
  69.  
  70.    begin
  71.       String_Skip (From, Pos);
  72.       Item := Scan_Real (From, Pos'Access, From'Last);
  73.       Last := Pos - 1;
  74.  
  75.    exception
  76.       when Constraint_Error =>
  77.          Last := Pos - 1;
  78.          raise Data_Error;
  79.    end Gets;
  80.  
  81.    ---------------
  82.    -- Load_Real --
  83.    ---------------
  84.  
  85.    procedure Load_Real
  86.      (File : in File_Type;
  87.       Buf  : out String;
  88.       Ptr  : in out Natural)
  89.    is
  90.       Loaded   : Boolean;
  91.  
  92.    begin
  93.       --  Skip initial blanks, and load possible sign
  94.  
  95.       Load_Skip (File);
  96.       Load (File, Buf, Ptr, '+', '-');
  97.  
  98.       --  Case of .nnnn
  99.  
  100.       Load (File, Buf, Ptr, '.', Loaded);
  101.  
  102.       if Loaded then
  103.          Load_Digits (File, Buf, Ptr, Loaded);
  104.  
  105.          --  Hopeless junk if no digits loaded
  106.  
  107.          if not Loaded then
  108.             return;
  109.          end if;
  110.  
  111.       --  Otherwise must have digits to start
  112.  
  113.       else
  114.          Load_Digits (File, Buf, Ptr, Loaded);
  115.  
  116.          --  Hopeless junk if no digits loaded
  117.  
  118.          if not Loaded then
  119.             return;
  120.          end if;
  121.  
  122.          --  Based cases
  123.  
  124.          Load (File, Buf, Ptr, '#', ':', Loaded);
  125.  
  126.          if Loaded then
  127.  
  128.             --  Case of nnn#.xxx#
  129.  
  130.             Load (File, Buf, Ptr, '.', Loaded);
  131.  
  132.             if Loaded then
  133.                Load_Extended_Digits (File, Buf, Ptr);
  134.  
  135.             --  Case of nnn#xxx.[xxx]# or nnn#xxx#
  136.  
  137.             else
  138.                Load_Extended_Digits (File, Buf, Ptr);
  139.                Load (File, Buf, Ptr, '.');
  140.                Load_Extended_Digits (File, Buf, Ptr);
  141.  
  142.                --  As usual, it seems strange to allow mixed base characters,
  143.                --  but that is what ACVC tests expect, see CE3804M, case (3).
  144.  
  145.                Load (File, Buf, Ptr, '#', ':');
  146.             end if;
  147.  
  148.          --  Case of nnn.[nnn] or nnn
  149.  
  150.          else
  151.             Load (File, Buf, Ptr, '.', Loaded);
  152.  
  153.             if Loaded then
  154.                Load_Digits (File, Buf, Ptr);
  155.             end if;
  156.          end if;
  157.       end if;
  158.  
  159.       --  Deal with exponent
  160.  
  161.       Load (File, Buf, Ptr, 'E', 'e', Loaded);
  162.  
  163.       if Loaded then
  164.          Load (File, Buf, Ptr, '+', '-');
  165.          Load_Digits (File, Buf, Ptr);
  166.       end if;
  167.    end Load_Real;
  168.  
  169.    ---------
  170.    -- Put --
  171.    ---------
  172.  
  173.    procedure Put
  174.      (File : in File_Type;
  175.       Item : in Long_Long_Float;
  176.       Fore : in Field;
  177.       Aft  : in Field;
  178.       Exp  : in Field)
  179.    is
  180.       Buf : String (1 .. Field'Last);
  181.       Ptr : Natural := 0;
  182.  
  183.    begin
  184.       Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
  185.       Put_Item (File, Buf (1 .. Ptr));
  186.    end Put;
  187.  
  188.    ----------
  189.    -- Puts --
  190.    ----------
  191.  
  192.    procedure Puts
  193.      (To   : out String;
  194.       Item : in Long_Long_Float;
  195.       Aft  : in Field;
  196.       Exp  : in Field)
  197.    is
  198.       Buf  : String (1 .. Field'Last);
  199.       Fore : Integer;
  200.       Ptr  : Natural := 0;
  201.  
  202.    begin
  203.       if Exp = 0 then
  204.          Fore := To'Length - 1 - Aft;
  205.       else
  206.          Fore := To'Length - 2 - Aft - Exp;
  207.       end if;
  208.  
  209.       if Fore < 1 then
  210.          raise Layout_Error;
  211.       end if;
  212.  
  213.       Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
  214.  
  215.       if Ptr > To'Length then
  216.          raise Layout_Error;
  217.       else
  218.          To := Buf (1 .. Ptr);
  219.       end if;
  220.    end Puts;
  221.  
  222. end Ada.Text_IO.Float_Aux;
  223.