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 / a-tiinau.adb < prev    next >
Text File  |  2000-07-19  |  9KB  |  298 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUN-TIME COMPONENTS                         --
  4. --                                                                          --
  5. --              A D A . T E X T _ I O . I N T E G E R  _ A U X              --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.9 $
  10. --                                                                          --
  11. --          Copyright (C) 1992-1999 Free Software Foundation, Inc.          --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  37.  
  38. with System.Img_BIU;   use System.Img_BIU;
  39. with System.Img_Int;   use System.Img_Int;
  40. with System.Img_LLB;   use System.Img_LLB;
  41. with System.Img_LLI;   use System.Img_LLI;
  42. with System.Img_LLW;   use System.Img_LLW;
  43. with System.Img_WIU;   use System.Img_WIU;
  44. with System.Val_Int;   use System.Val_Int;
  45. with System.Val_LLI;   use System.Val_LLI;
  46.  
  47. package body Ada.Text_IO.Integer_Aux is
  48.  
  49.    -----------------------
  50.    -- Local Subprograms --
  51.    -----------------------
  52.  
  53.    procedure Load_Integer
  54.      (File : in File_Type;
  55.       Buf  : out String;
  56.       Ptr  : in out Natural);
  57.    --  This is an auxiliary routine that is used to load an possibly signed
  58.    --  integer literal value from the input file into Buf, starting at Ptr + 1.
  59.    --  On return, Ptr is set to the last character stored.
  60.  
  61.    -------------
  62.    -- Get_Int --
  63.    -------------
  64.  
  65.    procedure Get_Int
  66.      (File  : in File_Type;
  67.       Item  : out Integer;
  68.       Width : in Field)
  69.    is
  70.       Buf  : String (1 .. Field'Last);
  71.       Ptr  : aliased Integer := 1;
  72.       Stop : Integer := 0;
  73.  
  74.    begin
  75.       if Width /= 0 then
  76.          Load_Width (File, Width, Buf, Stop);
  77.          String_Skip (Buf, Ptr);
  78.       else
  79.          Load_Integer (File, Buf, Stop);
  80.       end if;
  81.  
  82.       Item := Scan_Integer (Buf, Ptr'Access, Stop);
  83.       Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
  84.    end Get_Int;
  85.  
  86.    -------------
  87.    -- Get_LLI --
  88.    -------------
  89.  
  90.    procedure Get_LLI
  91.      (File  : in File_Type;
  92.       Item  : out Long_Long_Integer;
  93.       Width : in Field)
  94.    is
  95.       Buf  : String (1 .. Field'Last);
  96.       Ptr  : aliased Integer := 1;
  97.       Stop : Integer := 0;
  98.  
  99.    begin
  100.       if Width /= 0 then
  101.          Load_Width (File, Width, Buf, Stop);
  102.          String_Skip (Buf, Ptr);
  103.       else
  104.          Load_Integer (File, Buf, Stop);
  105.       end if;
  106.  
  107.       Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop);
  108.       Check_End_Of_Field (File, Buf, Stop, Ptr, Width);
  109.    end Get_LLI;
  110.  
  111.    --------------
  112.    -- Gets_Int --
  113.    --------------
  114.  
  115.    procedure Gets_Int
  116.      (From : in String;
  117.       Item : out Integer;
  118.       Last : out Positive)
  119.    is
  120.       Pos : aliased Integer;
  121.  
  122.    begin
  123.       String_Skip (From, Pos);
  124.       Item := Scan_Integer (From, Pos'Access, From'Last);
  125.       Last := Pos - 1;
  126.  
  127.    exception
  128.       when Constraint_Error =>
  129.          Last := Pos - 1;
  130.          raise Data_Error;
  131.    end Gets_Int;
  132.  
  133.    --------------
  134.    -- Gets_LLI --
  135.    --------------
  136.  
  137.    procedure Gets_LLI
  138.      (From : in String;
  139.       Item : out Long_Long_Integer;
  140.       Last : out Positive)
  141.    is
  142.       Pos : aliased Integer;
  143.  
  144.    begin
  145.       String_Skip (From, Pos);
  146.       Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
  147.       Last := Pos - 1;
  148.  
  149.    exception
  150.       when Constraint_Error =>
  151.          Last := Pos - 1;
  152.          raise Data_Error;
  153.    end Gets_LLI;
  154.  
  155.    ------------------
  156.    -- Load_Integer --
  157.    ------------------
  158.  
  159.    procedure Load_Integer
  160.      (File : in File_Type;
  161.       Buf  : out String;
  162.       Ptr  : in out Natural)
  163.    is
  164.       Hash_Loc : Natural;
  165.       Loaded   : Boolean;
  166.  
  167.    begin
  168.       Load_Skip (File);
  169.       Load (File, Buf, Ptr, '+', '-');
  170.  
  171.       Load_Digits (File, Buf, Ptr, Loaded);
  172.  
  173.       if Loaded then
  174.          Load (File, Buf, Ptr, '#', ':', Loaded);
  175.  
  176.          if Loaded then
  177.             Hash_Loc := Ptr;
  178.             Load_Extended_Digits (File, Buf, Ptr);
  179.             Load (File, Buf, Ptr, Buf (Hash_Loc));
  180.          end if;
  181.  
  182.          Load (File, Buf, Ptr, 'E', 'e', Loaded);
  183.  
  184.          if Loaded then
  185.  
  186.             --  Note: it is strange to allow a minus sign, since the syntax
  187.             --  does not, but that is what ACVC test CE3704F, case (6) wants.
  188.  
  189.             Load (File, Buf, Ptr, '+', '-');
  190.             Load_Digits (File, Buf, Ptr);
  191.          end if;
  192.       end if;
  193.    end Load_Integer;
  194.  
  195.    -------------
  196.    -- Put_Int --
  197.    -------------
  198.  
  199.    procedure Put_Int
  200.      (File  : in File_Type;
  201.       Item  : in Integer;
  202.       Width : in Field;
  203.       Base  : in Number_Base)
  204.    is
  205.       Buf : String (1 .. Integer'Max (Field'Last, Width));
  206.       Ptr : Natural := 0;
  207.  
  208.    begin
  209.       if Base = 10 and then Width = 0 then
  210.          Set_Image_Integer (Item, Buf, Ptr);
  211.       elsif Base = 10 then
  212.          Set_Image_Width_Integer (Item, Width, Buf, Ptr);
  213.       else
  214.          Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
  215.       end if;
  216.  
  217.       Put_Item (File, Buf (1 .. Ptr));
  218.    end Put_Int;
  219.  
  220.    -------------
  221.    -- Put_LLI --
  222.    -------------
  223.  
  224.    procedure Put_LLI
  225.      (File  : in File_Type;
  226.       Item  : in Long_Long_Integer;
  227.       Width : in Field;
  228.       Base  : in Number_Base)
  229.    is
  230.       Buf : String (1 .. Integer'Max (Field'Last, Width));
  231.       Ptr : Natural := 0;
  232.  
  233.    begin
  234.       if Base = 10 and then Width = 0 then
  235.          Set_Image_Long_Long_Integer (Item, Buf, Ptr);
  236.       elsif Base = 10 then
  237.          Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
  238.       else
  239.          Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
  240.       end if;
  241.  
  242.       Put_Item (File, Buf (1 .. Ptr));
  243.    end Put_LLI;
  244.  
  245.    --------------
  246.    -- Puts_Int --
  247.    --------------
  248.  
  249.    procedure Puts_Int
  250.      (To   : out String;
  251.       Item : in Integer;
  252.       Base : in Number_Base)
  253.    is
  254.       Buf : String (1 .. Integer'Max (Field'Last, To'Length));
  255.       Ptr : Natural := 0;
  256.  
  257.    begin
  258.       if Base = 10 then
  259.          Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
  260.       else
  261.          Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
  262.       end if;
  263.  
  264.       if Ptr > To'Length then
  265.          raise Layout_Error;
  266.       else
  267.          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
  268.       end if;
  269.    end Puts_Int;
  270.  
  271.    --------------
  272.    -- Puts_LLI --
  273.    --------------
  274.  
  275.    procedure Puts_LLI
  276.      (To   : out String;
  277.       Item : in Long_Long_Integer;
  278.       Base : in Number_Base)
  279.    is
  280.       Buf : String (1 .. Integer'Max (Field'Last, To'Length));
  281.       Ptr : Natural := 0;
  282.  
  283.    begin
  284.       if Base = 10 then
  285.          Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
  286.       else
  287.          Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
  288.       end if;
  289.  
  290.       if Ptr > To'Length then
  291.          raise Layout_Error;
  292.       else
  293.          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
  294.       end if;
  295.    end Puts_LLI;
  296.  
  297. end Ada.Text_IO.Integer_Aux;
  298.