Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/misc/fget.src

Text File | 1988-05-03 | 10.9 KB | 280 lines

--::::::::::
--fget.pro
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : FGET
-- Version      : 1.0
-- Author       : Richard Conn
--              : TI Ada Technology Branch
--              : PO Box 801, MS 8007
--              : McKinney, TX  75069
-- DDN Address  : RCONN at SIMTEL20
-- Copyright    : N/A
-- Date created : 15 Apr 85
-- Release date : 15 Apr 85
-- Last update  : 15 Apr 85
-- Machine/System Compiled/Run on : DG MV 10000, ROLM ADE
--                                  DEC VAX 11/785, DEC Ada
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     : character I/O, GETC, UNGETC, GETCH, GET_CHAR
----------------:
--
-- Abstract     :
--       Package FGET manipulates an object which is a text file. Its
-- main purpose is to return characters from this file, allowing one-character
-- look-ahead.  A character which has been obtained from the file via GETC can
-- be returned to the file by an UNGETC, in which case the next GETC will return
-- the same character again.  Additionally, GETC returns ASCII.CR if the end of
-- a text line is reached and ASCII.ETX if the end of the file is reached.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION AUTHOR                  HISTORY
-- 4/15/85      1.0     Richard Conn            Initial Release
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- Restrictions on use or distribution:  NONE
--                                                           -*
------------------ Disclaimer ---------------------------------
--                                                           -*
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--                                                           -*
-------------------END-PROLOGUE--------------------------------
--::::::::::
--fget.ada
--::::::::::
with TEXT_IO;
package FGET is
--------------------------------------------------------------------------
-- Abstract: Package FGET manipulates an object which is a text file. Its
-- main purpose is to return characters from this file, allowing one-character
-- look-ahead.  A character which has been obtained from the file via GETC can
-- be returned to the file by an UNGETC, in which case the next GETC will return
-- the same character again.  Additionally, GETC returns ASCII.CR if the end of
-- a text line is reached and ASCII.ETX if the end of the file is reached.
--------------------------------------------------------------------------

    type FILE_ID is limited private;

    OPEN_ERROR : exception;
--------------------------------------------------------------------------
-- OPEN_ERROR is raised if a file cannot be opened by the OPEN procedure or
-- if GETC or UNGETC are invoked on an unopened file.
--------------------------------------------------------------------------

    procedure OPEN (ID : in out FILE_ID; FILE_NAME : STRING);
--------------------------------------------------------------------------
-- Open the file for input via GETC.
--------------------------------------------------------------------------

    procedure GETC   (ID : in out FILE_ID; CH : out CHARACTER);
    procedure UNGETC (ID : in out FILE_ID; CH : CHARACTER);
--------------------------------------------------------------------------
-- GETC returns the next character from the file.  ASCII.CR is returned if
-- the last character returned was the last character of a line, and ASCII.ETX
-- is returned if the end of file is encountered.

-- UNGETC sets the indicated character as the next character to be returned
-- by GETC.
--------------------------------------------------------------------------

    procedure CLOSE (ID : in out FILE_ID);
--------------------------------------------------------------------------
-- Close the file previously opened by the OPEN procedure.
--------------------------------------------------------------------------

    function LINE_COUNT (ID : FILE_ID) return NATURAL;
--------------------------------------------------------------------------
-- Return the number of the current line in the file.  This is a number from
-- 1 to N, where N is the number of lines in the file.
--------------------------------------------------------------------------

private
    INPUT_LINE_LENGTH : constant NATURAL := 256; -- max length of line
    type FILE_ID is
        record
            FID             : TEXT_IO.FILE_TYPE;
            IS_CHAR_PENDING : BOOLEAN := FALSE;
            PENDING_CHAR    : CHARACTER;
            INPUT_LINE      : STRING (1 .. INPUT_LINE_LENGTH);
            NEXT_CHAR_INDEX : NATURAL := 1;
            LAST_CHAR_INDEX : NATURAL := 0;
            LINE_NUMBER     : NATURAL := 0;
        end record;

end FGET;

package body FGET is

--
-- Initialize for future GETC/UNGETC
--
    procedure OPEN (ID : in out FILE_ID; FILE_NAME : STRING) is
    begin
        TEXT_IO.OPEN (ID.FID, TEXT_IO.IN_FILE, FILE_NAME);
        ID.IS_CHAR_PENDING := FALSE;
        ID.NEXT_CHAR_INDEX := 1;
        ID.LAST_CHAR_INDEX := 0;
        ID.LINE_NUMBER := 0;
    exception
        when others =>
            raise OPEN_ERROR;
    end OPEN;

--
-- Close a file
--
    procedure CLOSE (ID : in out FILE_ID) is
    begin
        TEXT_IO.CLOSE (ID.FID);
    end CLOSE;

--
-- Return next character from file
--
    procedure GETC (ID : in out FILE_ID; CH : out CHARACTER) is
    begin
--
-- If a character is pending, then return it
--
        if ID.IS_CHAR_PENDING then
            CH := ID.PENDING_CHAR;
            ID.IS_CHAR_PENDING := FALSE;
            --
            -- Else return next character from file if not at end of file
            --
        else
            if ID.NEXT_CHAR_INDEX > ID.LAST_CHAR_INDEX then
                TEXT_IO.GET_LINE (ID.FID, ID.INPUT_LINE, ID.LAST_CHAR_INDEX);
                ID.LINE_NUMBER := ID.LINE_NUMBER + 1;
                if ID.LAST_CHAR_INDEX /= ID.INPUT_LINE'LAST then
                    ID.LAST_CHAR_INDEX := ID.LAST_CHAR_INDEX + 1;
                end if;
                ID.INPUT_LINE (ID.LAST_CHAR_INDEX) := ASCII.CR;
                ID.NEXT_CHAR_INDEX := 1;
            end if;
            CH := ID.INPUT_LINE (ID.NEXT_CHAR_INDEX);
            ID.NEXT_CHAR_INDEX := ID.NEXT_CHAR_INDEX + 1;
        end if;
    exception
--
-- Indicate end of file with ETX
--
        when TEXT_IO.END_ERROR =>
            CH := ASCII.ETX;
        when others =>
            raise OPEN_ERROR;
    end GETC;

--
-- Set next character to be returned by GETC
--
    procedure UNGETC (ID : in out FILE_ID; CH : CHARACTER) is
    begin
        if not TEXT_IO.IS_OPEN (ID.FID) then
            raise OPEN_ERROR;
        end if;
        ID.IS_CHAR_PENDING := TRUE;
        ID.PENDING_CHAR := CH;
    end UNGETC;

--
-- Return count of lines
--
    function LINE_COUNT (ID : FILE_ID) return NATURAL is
    begin
        if not TEXT_IO.IS_OPEN (ID.FID) then
            raise OPEN_ERROR;
        end if;
        return ID.LINE_NUMBER;
    end LINE_COUNT;

end FGET;
--::::::::::
--test_fget.ada
--::::::::::
with TEXT_IO,
     FGET;
procedure TEST_FGET is

---------------------------------------------------------------------------
-- Background: This test is a simple, yet dramatic, demonstration of the
-- capabilities afforded by the routines in FGET.  This program passes through
-- an input file and extracts (and prints) the words in this file.  A word
-- is defined as being a sequence of one or more alphanumeric characters.
-- The program does this by extracting characters until an alphanumeric is
-- found, building a word until a non-alphanumeric is found, and then
-- printing the word and putting the last (invalid) character back in case
-- it was a new line (ASCII.CR) or end of file (ASCII.ETX) indicator.
-- The tests for new line and end of file are done at the beginning of the
-- loop, so this "put-back" procedure prepares the last character of the word
-- for the tests at the beginning of the loop.
---------------------------------------------------------------------------

    INPUT_FILE             : FGET.FILE_ID;
    INPUT_FILE_NAME        : STRING (1 .. 60);
    INPUT_FILE_NAME_LENGTH : NATURAL;
    IN_CHAR                : CHARACTER;

    function IS_ALPHA_NUMERIC (CH : CHARACTER) return BOOLEAN is
    begin
        return (CH in 'A' .. 'Z') or (CH in 'a' .. 'z') or (CH in '0' .. '9');
    end IS_ALPHA_NUMERIC;

begin
    TEXT_IO.PUT ("Input File Name > ");
    TEXT_IO.GET_LINE (INPUT_FILE_NAME, INPUT_FILE_NAME_LENGTH);
    FGET.OPEN (INPUT_FILE, INPUT_FILE_NAME (1 .. INPUT_FILE_NAME_LENGTH));
    loop
        FGET.GETC (INPUT_FILE, IN_CHAR);
        if IS_ALPHA_NUMERIC (IN_CHAR) then
            -- Alpha-numeric character found - print word
            TEXT_IO.PUT (IN_CHAR);
            loop
                FGET.GETC (INPUT_FILE, IN_CHAR);
                exit when not IS_ALPHA_NUMERIC (IN_CHAR);
                TEXT_IO.PUT (IN_CHAR);
            end loop;
            FGET.UNGETC (INPUT_FILE, IN_CHAR);
            TEXT_IO.PUT ("  ");
        else
-- Non-alpha-numeric character found - test of ETX or CR
            case IN_CHAR is
                when ASCII.ETX =>  exit;
                when ASCII.CR  =>  TEXT_IO.NEW_LINE;
                when others    =>  null;
            end case;
        end if;
    end loop;
    TEXT_IO.NEW_LINE;
    FGET.CLOSE (INPUT_FILE);
exception
    when FGET.OPEN_ERROR =>  TEXT_IO.PUT_LINE ("Open File Error");
    when TEXT_IO.END_ERROR =>  TEXT_IO.PUT_LINE ("Bad EOF");
end TEST_FGET;