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-tigeau.adb < prev    next >
Text File  |  1996-09-28  |  12KB  |  481 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT RUNTIME COMPONENTS                          --
  4. --                                                                          --
  5. --              A D A . T E X T _ I O . G E N E R I C _ A U X               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.13 $                             --
  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 Interfaces.C_Streams; use Interfaces.C_Streams;
  27. with System.File_IO;
  28. with System.File_Control_Block;
  29.  
  30. package body Ada.Text_IO.Generic_Aux is
  31.  
  32.    package FIO renames System.File_IO;
  33.    package FCB renames System.File_Control_Block;
  34.    subtype AP is FCB.AFCB_Ptr;
  35.  
  36.    ------------------------
  37.    -- Check_End_Of_Field --
  38.    ------------------------
  39.  
  40.    procedure Check_End_Of_Field
  41.      (File  : File_Type;
  42.       Buf   : String;
  43.       Stop  : Integer;
  44.       Ptr   : Integer;
  45.       Width : Field)
  46.    is
  47.    begin
  48.       if Ptr > Stop then
  49.          return;
  50.  
  51.       elsif Width = 0 then
  52.          raise Data_Error;
  53.  
  54.       else
  55.          for J in Ptr .. Stop loop
  56.             if not Is_Blank (Buf (J)) then
  57.                raise Data_Error;
  58.             end if;
  59.          end loop;
  60.       end if;
  61.    end Check_End_Of_Field;
  62.  
  63.    -----------------------
  64.    -- Check_On_One_Line --
  65.    -----------------------
  66.  
  67.    procedure Check_On_One_Line
  68.      (File   : File_Type;
  69.       Length : Integer)
  70.    is
  71.    begin
  72.       FIO.Check_Write_Status (AP (File));
  73.  
  74.       if File.Line_Length /= 0 then
  75.          if Count (Length) > File.Line_Length then
  76.             raise Layout_Error;
  77.          elsif File.Col + Count (Length) > File.Line_Length + 1 then
  78.             New_Line (File);
  79.          end if;
  80.       end if;
  81.    end Check_On_One_Line;
  82.  
  83.    ----------
  84.    -- Getc --
  85.    ----------
  86.  
  87.    function Getc (File : File_Type) return int is
  88.       ch : int;
  89.  
  90.    begin
  91.       ch := fgetc (File.Stream);
  92.  
  93.       if ch = EOF and then ferror (File.Stream) /= 0 then
  94.          raise Device_Error;
  95.       else
  96.          return ch;
  97.       end if;
  98.    end Getc;
  99.  
  100.    --------------
  101.    -- Is_Blank --
  102.    --------------
  103.  
  104.    function Is_Blank (C : Character) return Boolean is
  105.    begin
  106.       return C = ' ' or else C = Ascii.HT;
  107.    end Is_Blank;
  108.  
  109.    ----------
  110.    -- Load --
  111.    ----------
  112.  
  113.    procedure Load
  114.      (File   : File_Type;
  115.       Buf    : out String;
  116.       Ptr    : in out Integer;
  117.       Char   : Character;
  118.       Loaded : out Boolean)
  119.    is
  120.       ch : int;
  121.  
  122.    begin
  123.       ch := Getc (File);
  124.  
  125.       if ch = Character'Pos (Char) then
  126.          Store_Char (File, ch, Buf, Ptr);
  127.          Loaded := True;
  128.       else
  129.          Ungetc (ch, File);
  130.          Loaded := False;
  131.       end if;
  132.    end Load;
  133.  
  134.    procedure Load
  135.      (File   : File_Type;
  136.       Buf    : out String;
  137.       Ptr    : in out Integer;
  138.       Char   : Character)
  139.    is
  140.       ch : int;
  141.  
  142.    begin
  143.       ch := Getc (File);
  144.  
  145.       if ch = Character'Pos (Char) then
  146.          Store_Char (File, ch, Buf, Ptr);
  147.       else
  148.          Ungetc (ch, File);
  149.       end if;
  150.    end Load;
  151.  
  152.    procedure Load
  153.      (File   : File_Type;
  154.       Buf    : out String;
  155.       Ptr    : in out Integer;
  156.       Char1  : Character;
  157.       Char2  : Character;
  158.       Loaded : out Boolean)
  159.    is
  160.       ch : int;
  161.  
  162.    begin
  163.       ch := Getc (File);
  164.  
  165.       if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
  166.          Store_Char (File, ch, Buf, Ptr);
  167.          Loaded := True;
  168.       else
  169.          Ungetc (ch, File);
  170.          Loaded := False;
  171.       end if;
  172.    end Load;
  173.  
  174.    procedure Load
  175.      (File   : File_Type;
  176.       Buf    : out String;
  177.       Ptr    : in out Integer;
  178.       Char1  : Character;
  179.       Char2  : Character)
  180.    is
  181.       ch : int;
  182.  
  183.    begin
  184.       ch := Getc (File);
  185.  
  186.       if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
  187.          Store_Char (File, ch, Buf, Ptr);
  188.       else
  189.          Ungetc (ch, File);
  190.       end if;
  191.    end Load;
  192.  
  193.    -----------------
  194.    -- Load_Digits --
  195.    -----------------
  196.  
  197.    procedure Load_Digits
  198.      (File   : File_Type;
  199.       Buf    : out String;
  200.       Ptr    : in out Integer;
  201.       Loaded : out Boolean)
  202.    is
  203.       ch          : int;
  204.       After_Digit : Boolean;
  205.  
  206.    begin
  207.       ch := Getc (File);
  208.  
  209.       if ch not in Character'Pos ('0') .. Character'Pos ('9') then
  210.          Loaded := False;
  211.  
  212.       else
  213.          Loaded := True;
  214.          After_Digit := True;
  215.  
  216.          loop
  217.             Store_Char (File, ch, Buf, Ptr);
  218.             ch := Getc (File);
  219.  
  220.             if ch in Character'Pos ('0') .. Character'Pos ('9') then
  221.                After_Digit := True;
  222.  
  223.             elsif ch = Character'Pos ('_') and then After_Digit then
  224.                After_Digit := False;
  225.  
  226.             else
  227.                exit;
  228.             end if;
  229.          end loop;
  230.       end if;
  231.  
  232.       Ungetc (ch, File);
  233.    end Load_Digits;
  234.  
  235.    procedure Load_Digits
  236.      (File   : File_Type;
  237.       Buf    : out String;
  238.       Ptr    : in out Integer)
  239.    is
  240.       ch          : int;
  241.       After_Digit : Boolean;
  242.  
  243.    begin
  244.       ch := Getc (File);
  245.  
  246.       if ch in Character'Pos ('0') .. Character'Pos ('9') then
  247.          After_Digit := True;
  248.  
  249.          loop
  250.             Store_Char (File, ch, Buf, Ptr);
  251.             ch := Getc (File);
  252.  
  253.             if ch in Character'Pos ('0') .. Character'Pos ('9') then
  254.                After_Digit := True;
  255.  
  256.             elsif ch = Character'Pos ('_') and then After_Digit then
  257.                After_Digit := False;
  258.  
  259.             else
  260.                exit;
  261.             end if;
  262.          end loop;
  263.       end if;
  264.  
  265.       Ungetc (ch, File);
  266.    end Load_Digits;
  267.  
  268.    --------------------------
  269.    -- Load_Extended_Digits --
  270.    --------------------------
  271.  
  272.    procedure Load_Extended_Digits
  273.      (File   : File_Type;
  274.       Buf    : out String;
  275.       Ptr    : in out Integer;
  276.       Loaded : out Boolean)
  277.    is
  278.       ch          : int;
  279.       After_Digit : Boolean := False;
  280.  
  281.    begin
  282.       Loaded := False;
  283.  
  284.       loop
  285.          ch := Getc (File);
  286.  
  287.          if ch in Character'Pos ('0') .. Character'Pos ('9')
  288.               or else
  289.             ch in Character'Pos ('a') .. Character'Pos ('f')
  290.               or else
  291.             ch in Character'Pos ('A') .. Character'Pos ('F')
  292.          then
  293.             After_Digit := True;
  294.  
  295.          elsif ch = Character'Pos ('_') and then After_Digit then
  296.             After_Digit := False;
  297.  
  298.          else
  299.             exit;
  300.          end if;
  301.  
  302.          Store_Char (File, ch, Buf, Ptr);
  303.          Loaded := True;
  304.       end loop;
  305.  
  306.       Ungetc (ch, File);
  307.    end Load_Extended_Digits;
  308.  
  309.    procedure Load_Extended_Digits
  310.      (File   : File_Type;
  311.       Buf    : out String;
  312.       Ptr    : in out Integer)
  313.    is
  314.       Junk : Boolean;
  315.  
  316.    begin
  317.       Load_Extended_Digits (File, Buf, Ptr, Junk);
  318.    end Load_Extended_Digits;
  319.  
  320.    ---------------
  321.    -- Load_Skip --
  322.    ---------------
  323.  
  324.    procedure Load_Skip (File  : File_Type) is
  325.       C : Character;
  326.  
  327.    begin
  328.       FIO.Check_Read_Status (AP (File));
  329.  
  330.       --  We need to explicitly test for the case of being before a wide
  331.       --  character (greater than 16#7F#) for the case of being used from
  332.       --  Wide_Text_IO. Since no such character can ever legitimately be
  333.       --  a valid numeric character, we can immediately signal Data_Error.
  334.  
  335.       if File.Before_Wide_Character then
  336.          raise Data_Error;
  337.       end if;
  338.  
  339.       --  Otherwise loop till we find a non-blank character (note that as
  340.       --  usual in Text_IO, blank includes horizontal tab). Note that Get
  341.       --  deals with the Before_LM and Before_LM_PM flags appropriately.
  342.  
  343.       loop
  344.          Get (File, C);
  345.          exit when not Is_Blank (C);
  346.       end loop;
  347.  
  348.       Ungetc (Character'Pos (C), File);
  349.       File.Col := File.Col - 1;
  350.    end Load_Skip;
  351.  
  352.    ----------------
  353.    -- Load_Width --
  354.    ----------------
  355.  
  356.    procedure Load_Width
  357.      (File  : File_Type;
  358.       Width : Field;
  359.       Buf   : out String;
  360.       Ptr   : in out Integer)
  361.    is
  362.       ch : int;
  363.  
  364.    begin
  365.       FIO.Check_Read_Status (AP (File));
  366.  
  367.       --  If we are immediately before a line mark, or before a wide character
  368.       --  that is not in the lower ASCII set, then we have no characters. This
  369.       --  is always a data error, so we may as well raise it right away.
  370.  
  371.       if File.Before_LM or File.Before_Wide_Character then
  372.          raise Data_Error;
  373.  
  374.       else
  375.          for J in 1 .. Width loop
  376.             ch := Getc (File);
  377.  
  378.             if ch = EOF then
  379.                return;
  380.  
  381.             elsif ch = LM then
  382.                Ungetc (ch, File);
  383.                return;
  384.  
  385.             else
  386.                Store_Char (File, ch, Buf, Ptr);
  387.             end if;
  388.          end loop;
  389.       end if;
  390.    end Load_Width;
  391.  
  392.    -----------
  393.    -- Nextc --
  394.    -----------
  395.  
  396.    function Nextc (File : File_Type) return int is
  397.       ch : int;
  398.  
  399.    begin
  400.       ch := fgetc (File.Stream);
  401.  
  402.       if ch = EOF then
  403.          if ferror (File.Stream) /= 0 then
  404.             raise Device_Error;
  405.          else
  406.             return EOF;
  407.          end if;
  408.  
  409.       else
  410.          Ungetc (ch, File);
  411.          return ch;
  412.       end if;
  413.    end Nextc;
  414.  
  415.    --------------
  416.    -- Put_Item --
  417.    --------------
  418.  
  419.    procedure Put_Item (File : File_Type; Str : String) is
  420.    begin
  421.       Check_On_One_Line (File, Str'Length);
  422.       Put (File, Str);
  423.    end Put_Item;
  424.  
  425.    ----------------
  426.    -- Store_Char --
  427.    ----------------
  428.  
  429.    procedure Store_Char
  430.      (File : File_Type;
  431.       ch   : int;
  432.       Buf  : out String;
  433.       Ptr  : in out Integer)
  434.    is
  435.    begin
  436.       File.Col := File.Col + 1;
  437.  
  438.       if Ptr = Buf'Last then
  439.          raise Data_Error;
  440.       else
  441.          Ptr := Ptr + 1;
  442.          Buf (Ptr) := Character'Val (ch);
  443.       end if;
  444.    end Store_Char;
  445.  
  446.    -----------------
  447.    -- String_Skip --
  448.    -----------------
  449.  
  450.    procedure String_Skip (Str : String; Ptr : out Positive'Base) is
  451.    begin
  452.       Ptr := Str'First;
  453.  
  454.       loop
  455.          if Ptr > Str'Last then
  456.             raise End_Error;
  457.  
  458.          elsif not Is_Blank (Str (Ptr)) then
  459.             return;
  460.  
  461.          else
  462.             Ptr := Ptr + 1;
  463.          end if;
  464.       end loop;
  465.    end String_Skip;
  466.  
  467.    ------------
  468.    -- Ungetc --
  469.    ------------
  470.  
  471.    procedure Ungetc (ch : int; File : File_Type) is
  472.    begin
  473.       if ch /= EOF then
  474.          if ungetc (ch, File.Stream) = EOF then
  475.             raise Device_Error;
  476.          end if;
  477.       end if;
  478.    end Ungetc;
  479.  
  480. end Ada.Text_IO.Generic_Aux;
  481.