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-wtinau.adb < prev    next >
Text File  |  2000-07-19  |  9KB  |  300 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --         A D A . W I D E _ 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.2 $                              --
  10. --                                                                          --
  11. --   Copyright (C) 1992,1993,1994,1995,1996 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_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.Wide_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.  
  132.    end Gets_Int;
  133.  
  134.    --------------
  135.    -- Gets_LLI --
  136.    --------------
  137.  
  138.    procedure Gets_LLI
  139.      (From : in String;
  140.       Item : out Long_Long_Integer;
  141.       Last : out Positive)
  142.    is
  143.       Pos : aliased Integer;
  144.  
  145.    begin
  146.       String_Skip (From, Pos);
  147.       Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last);
  148.       Last := Pos - 1;
  149.  
  150.    exception
  151.       when Constraint_Error =>
  152.          Last := Pos - 1;
  153.          raise Data_Error;
  154.  
  155.    end Gets_LLI;
  156.  
  157.    ------------------
  158.    -- Load_Integer --
  159.    ------------------
  160.  
  161.    procedure Load_Integer
  162.      (File : in File_Type;
  163.       Buf  : out String;
  164.       Ptr  : in out Natural)
  165.    is
  166.       Hash_Loc : Natural;
  167.       Loaded   : Boolean;
  168.  
  169.    begin
  170.       Load_Skip (File);
  171.       Load (File, Buf, Ptr, '+', '-');
  172.  
  173.       Load_Digits (File, Buf, Ptr, Loaded);
  174.  
  175.       if Loaded then
  176.          Load (File, Buf, Ptr, '#', ':', Loaded);
  177.  
  178.          if Loaded then
  179.             Hash_Loc := Ptr;
  180.             Load_Extended_Digits (File, Buf, Ptr);
  181.             Load (File, Buf, Ptr, Buf (Hash_Loc));
  182.          end if;
  183.  
  184.          Load (File, Buf, Ptr, 'E', 'e', Loaded);
  185.  
  186.          if Loaded then
  187.  
  188.             --  Note: it is strange to allow a minus sign, since the syntax
  189.             --  does not, but that is what ACVC test CE3704F, case (6) wants.
  190.  
  191.             Load (File, Buf, Ptr, '+', '-');
  192.             Load_Digits (File, Buf, Ptr);
  193.          end if;
  194.       end if;
  195.    end Load_Integer;
  196.  
  197.    -------------
  198.    -- Put_Int --
  199.    -------------
  200.  
  201.    procedure Put_Int
  202.      (File  : in File_Type;
  203.       Item  : in Integer;
  204.       Width : in Field;
  205.       Base  : in Number_Base)
  206.    is
  207.       Buf : String (1 .. Field'Last);
  208.       Ptr : Natural := 0;
  209.  
  210.    begin
  211.       if Base = 10 and then Width = 0 then
  212.          Set_Image_Integer (Item, Buf, Ptr);
  213.       elsif Base = 10 then
  214.          Set_Image_Width_Integer (Item, Width, Buf, Ptr);
  215.       else
  216.          Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr);
  217.       end if;
  218.  
  219.       Put_Item (File, Buf (1 .. Ptr));
  220.    end Put_Int;
  221.  
  222.    -------------
  223.    -- Put_LLI --
  224.    -------------
  225.  
  226.    procedure Put_LLI
  227.      (File  : in File_Type;
  228.       Item  : in Long_Long_Integer;
  229.       Width : in Field;
  230.       Base  : in Number_Base)
  231.    is
  232.       Buf : String (1 .. Field'Last);
  233.       Ptr : Natural := 0;
  234.  
  235.    begin
  236.       if Base = 10 and then Width = 0 then
  237.          Set_Image_Long_Long_Integer (Item, Buf, Ptr);
  238.       elsif Base = 10 then
  239.          Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr);
  240.       else
  241.          Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr);
  242.       end if;
  243.  
  244.       Put_Item (File, Buf (1 .. Ptr));
  245.    end Put_LLI;
  246.  
  247.    --------------
  248.    -- Puts_Int --
  249.    --------------
  250.  
  251.    procedure Puts_Int
  252.      (To   : out String;
  253.       Item : in Integer;
  254.       Base : in Number_Base)
  255.    is
  256.       Buf : String (1 .. Field'Last);
  257.       Ptr : Natural := 0;
  258.  
  259.    begin
  260.       if Base = 10 then
  261.          Set_Image_Width_Integer (Item, To'Length, Buf, Ptr);
  262.       else
  263.          Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr);
  264.       end if;
  265.  
  266.       if Ptr > To'Length then
  267.          raise Layout_Error;
  268.       else
  269.          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
  270.       end if;
  271.    end Puts_Int;
  272.  
  273.    --------------
  274.    -- Puts_LLI --
  275.    --------------
  276.  
  277.    procedure Puts_LLI
  278.      (To   : out String;
  279.       Item : in Long_Long_Integer;
  280.       Base : in Number_Base)
  281.    is
  282.       Buf : String (1 .. Field'Last);
  283.       Ptr : Natural := 0;
  284.  
  285.    begin
  286.       if Base = 10 then
  287.          Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr);
  288.       else
  289.          Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr);
  290.       end if;
  291.  
  292.       if Ptr > To'Length then
  293.          raise Layout_Error;
  294.       else
  295.          To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr);
  296.       end if;
  297.    end Puts_LLI;
  298.  
  299. end Ada.Wide_Text_IO.Integer_Aux;
  300.