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-tideau.adb < prev    next >
Text File  |  1996-09-28  |  7KB  |  253 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --              A D A . T E X T _ I O . D E C I M A L _ A U X               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.8 $                              --
  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. with Ada.Text_IO.Float_Aux;   use Ada.Text_IO.Float_Aux;
  28.  
  29. with System.Img_Dec; use System.Img_Dec;
  30. with System.Img_LLD; use System.Img_LLD;
  31. with System.Val_Dec; use System.Val_Dec;
  32. with System.Val_LLD; use System.Val_LLD;
  33.  
  34. package body Ada.Text_IO.Decimal_Aux is
  35.  
  36.    -------------
  37.    -- Get_Dec --
  38.    -------------
  39.  
  40.    function Get_Dec
  41.      (File   : in File_Type;
  42.       Width  : in Field;
  43.       Scale  : Integer)
  44.       return   Integer
  45.    is
  46.       Buf  : String (1 .. Field'Last);
  47.       Ptr  : aliased Integer := 0;
  48.       Stop : Integer := 0;
  49.       Item : Integer;
  50.  
  51.    begin
  52.       if Width /= 0 then
  53.          Load_Width (File, Width, Buf, Stop);
  54.          String_Skip (Buf, Ptr);
  55.       else
  56.          Load_Real (File, Buf, Stop);
  57.       end if;
  58.  
  59.       Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale);
  60.       Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
  61.       return Item;
  62.    end Get_Dec;
  63.  
  64.    -------------
  65.    -- Get_LLD --
  66.    -------------
  67.  
  68.    function Get_LLD
  69.      (File   : in File_Type;
  70.       Width  : in Field;
  71.       Scale  : Integer)
  72.       return   Long_Long_Integer
  73.    is
  74.       Buf  : String (1 .. Field'Last);
  75.       Ptr  : aliased Integer := 0;
  76.       Stop : Integer := 0;
  77.       Item : Long_Long_Integer;
  78.  
  79.    begin
  80.       if Width /= 0 then
  81.          Load_Width (File, Width, Buf, Stop);
  82.          String_Skip (Buf, Ptr);
  83.       else
  84.          Load_Real (File, Buf, Stop);
  85.       end if;
  86.  
  87.       Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale);
  88.       Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
  89.       return Item;
  90.    end Get_LLD;
  91.  
  92.    -------------
  93.    -- Put_Dec --
  94.    -------------
  95.  
  96.    procedure Put_Dec
  97.      (File  : in File_Type;
  98.       Item  : in Integer;
  99.       Fore  : in Field;
  100.       Aft   : in Field;
  101.       Exp   : in Field;
  102.       Scale : Integer)
  103.    is
  104.       Buf : String (1 .. Field'Last);
  105.       Ptr : Natural := 0;
  106.  
  107.    begin
  108.       Set_Image_Decimal (Item, Buf, Ptr, Fore, Aft, Exp, Scale);
  109.       Put_Item (File, Buf (1 .. Ptr));
  110.    end Put_Dec;
  111.  
  112.    -------------
  113.    -- Put_LLD --
  114.    -------------
  115.  
  116.    procedure Put_LLD
  117.      (File  : in File_Type;
  118.       Item  : in Long_Long_Integer;
  119.       Fore  : in Field;
  120.       Aft   : in Field;
  121.       Exp   : in Field;
  122.       Scale : Integer)
  123.    is
  124.       Buf : String (1 .. Field'Last);
  125.       Ptr : Natural := 0;
  126.  
  127.    begin
  128.       Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Fore, Aft, Exp, Scale);
  129.       Put_Item (File, Buf (1 .. Ptr));
  130.    end Put_LLD;
  131.  
  132.    --------------
  133.    -- Gets_Dec --
  134.    --------------
  135.  
  136.    function Gets_Dec
  137.      (From  : in String;
  138.       Last  : access Positive;
  139.       Scale : Integer)
  140.       return  Integer
  141.    is
  142.       Pos  : aliased Integer;
  143.       Item : Integer;
  144.  
  145.    begin
  146.       String_Skip (From, Pos);
  147.       Item := Scan_Decimal (From, Pos'Access, From'Last, Scale);
  148.       Last.all := Pos - 1;
  149.       return Item;
  150.  
  151.    exception
  152.       when Constraint_Error =>
  153.          Last.all := Pos - 1;
  154.          raise Data_Error;
  155.    end Gets_Dec;
  156.  
  157.    --------------
  158.    -- Gets_LLD --
  159.    --------------
  160.  
  161.    function Gets_LLD
  162.      (From  : in String;
  163.       Last  : access Positive;
  164.       Scale : Integer)
  165.       return  Long_Long_Integer
  166.    is
  167.       Pos  : aliased Integer := From'First;
  168.       Item : Long_Long_Integer;
  169.  
  170.    begin
  171.       String_Skip (From, Pos);
  172.       Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale);
  173.       Last.all := Pos - 1;
  174.       return Item;
  175.  
  176.    exception
  177.       when Constraint_Error =>
  178.          Last.all := Pos - 1;
  179.          raise Data_Error;
  180.    end Gets_LLD;
  181.  
  182.    --------------
  183.    -- Puts_Dec --
  184.    --------------
  185.  
  186.    procedure Puts_Dec
  187.      (To    : out String;
  188.       Item  : in Integer;
  189.       Aft   : in Field;
  190.       Exp   : in Field;
  191.       Scale : Integer)
  192.    is
  193.       Buf  : String (1 .. Field'Last);
  194.       Fore : Integer;
  195.       Ptr  : Natural := 0;
  196.  
  197.    begin
  198.       if Exp = 0 then
  199.          Fore := To'Length - 1 - Aft;
  200.       else
  201.          Fore := To'Length - 2 - Aft - Exp;
  202.       end if;
  203.  
  204.       if Fore < 1 then
  205.          raise Layout_Error;
  206.       end if;
  207.  
  208.       Set_Image_Decimal (Item, Buf, Ptr, Fore, Aft, Exp, Scale);
  209.  
  210.       if Ptr > To'Length then
  211.          raise Layout_Error;
  212.       else
  213.          To := Buf (1 .. Ptr);
  214.       end if;
  215.    end Puts_Dec;
  216.  
  217.    --------------
  218.    -- Puts_Dec --
  219.    --------------
  220.  
  221.    procedure Puts_LLD
  222.      (To    : out String;
  223.       Item  : in Long_Long_Integer;
  224.       Aft   : in Field;
  225.       Exp   : in Field;
  226.       Scale : Integer)
  227.    is
  228.       Buf  : String (1 .. Field'Last);
  229.       Fore : Integer;
  230.       Ptr  : Natural := 0;
  231.  
  232.    begin
  233.       if Exp = 0 then
  234.          Fore := To'Length - 1 - Aft;
  235.       else
  236.          Fore := To'Length - 2 - Aft - Exp;
  237.       end if;
  238.  
  239.       if Fore < 1 then
  240.          raise Layout_Error;
  241.       end if;
  242.  
  243.       Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Fore, Aft, Exp, Scale);
  244.  
  245.       if Ptr > To'Length then
  246.          raise Layout_Error;
  247.       else
  248.          To := Buf (1 .. Ptr);
  249.       end if;
  250.    end Puts_LLD;
  251.  
  252. end Ada.Text_IO.Decimal_Aux;
  253.