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

Text File | 1988-05-03 | 16.1 KB | 542 lines

::::::::::
IOSPT.ADA
::::::::::




-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : IO_SUPPORT
-- Version      : 1.0
-- Author       : Richard Conn
--              : Texas Instruments, Ada Technology Branch
--              : PO Box 801, MS 8007
--              : McKinney, TX  75069
-- DDN Address  : RCONN at SIMTEL20
-- Copyright    : (c) 1985 Richard Conn
-- Date created : 15 Feb 85
-- Release date : 15 Feb 85
-- Last update  : 15 Feb 85
-- Machine/System Compiled/Run on : DG MV 10000, ROLM ADE
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :
----------------: Input Line Editor, I/O Support
--
-- Abstract     :
----------------: IO_SUPPORT is a companion package for SYSDEP,
-- a system dependencies package that provides console input and
-- console output without echo on the input and without control
-- character interpretation.  IO_SUPPORT, which employs SYSDEP,
-- provides an input line editor and interfaces to the routines
-- in SYSDEP which provide a greater degree of functionality than
-- SYSDEP itself provides.
--
--      For applications which are embedded and do not require
-- features of TEXT_IO other than simple character or string I/O,
-- IO_SUPPORT with SYSDEP offer an alternative to withing in the
-- entire TEXT_IO package.
--
--      The philosophy behind creating SYSDEP is to provide low-level
-- I/O routines which can be built upon to implement applications which
-- require raw I/O, such as communications servers and character-oriented
-- tools.  IO_SUPPORT goes one step further by providing a set of
-- commonly-used routines around SYSDEP, preventing the need for
-- constantly reinventing the basic wheel.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION AUTHOR                  HISTORY
-- 2/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 copyright by the author.
--
-- This software is released to the Ada community.
-- 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--------------------------------
--
-- Components Package IO_SUPPORT
--  Written by Richard Conn, TI Ada Technology Branch
--

package IO_SUPPORT is

--
-- Editor constants
--
    EDIT_DEL_CHAR    : constant CHARACTER := ASCII.DEL;
    EDIT_DEL_LINE    : constant CHARACTER := ASCII.NAK;
    EDIT_RETYPE_LINE : constant CHARACTER := ASCII.DC2;
    EDIT_QUOTE       : constant CHARACTER := '\';
    EDIT_TAB         : constant CHARACTER := ASCII.HT;
    TAB_SIZE         : constant NATURAL := 8; -- for indenting

--
-- The following initialization/deinitialization routines are provided:
--
    procedure CONSOLE_INIT; -- initialize console
    procedure CONSOLE_DEINIT; -- deinitialize console

--
-- GET_LINE inputs a line from the user as a string; padded with ASCII.NUL
--
    procedure GET_LINE    (INPUT_LINE : in out STRING);
    procedure GET_LINE    (INPUT_LINE : in out STRING; LAST : out NATURAL);
    function  LINE_LENGTH (INPUT_LINE : STRING) return NATURAL;

--
-- PUT and PUT_LINE output a string (padded with ASCII.NUL)
-- NEW_LINE outputs CRLF
-- PUT outputs a character without processing
--
    procedure PUT      (STR : STRING);
    procedure NEW_LINE;
    procedure PUT_LINE (STR : STRING);
    procedure PUT      (INCHAR : CHARACTER);


--
-- GETC inputs a character without echo; any character in the 128-char
--      ASCII character set may be input
-- GETC_WITH_ECHO is the same as GETC but echoes
-- UNGETC sets the next character to be returned by GETC or GETC_WITH_ECHO
--
    function  GETC           return CHARACTER;
    procedure GETC           (CH : out CHARACTER);
    function  GETC_WITH_ECHO return CHARACTER;
    procedure GETC_WITH_ECHO (CH : out CHARACTER);
    procedure UNGETC         (INCHAR : CHARACTER);


end IO_SUPPORT;


with SYSDEP;
package body IO_SUPPORT is

--
-- Local Globals
--
    GET_LINE_LENGTH      : NATURAL;
    CHARACTER_IS_PENDING : BOOLEAN := FALSE;
    PENDING_CHARACTER    : CHARACTER;


--
-- Initialize console
--
    procedure CONSOLE_INIT is
    begin
        SYSDEP.OPEN_CONSOLE;
    end CONSOLE_INIT;

--
-- Deinitialize console
--
    procedure CONSOLE_DEINIT is
    begin
        SYSDEP.CLOSE_CONSOLE;
    end CONSOLE_DEINIT;

--
-- PRINTING_CHARACTER indicates if the character presented to it is printable
-- (ie, occupies a position on the screen)
--
    function PRINTING_CHARACTER (INCHAR : CHARACTER) return BOOLEAN is
    begin
        if INCHAR >= ' ' and INCHAR < ASCII.DEL then
            return TRUE;
        else
            return FALSE;
        end if;
    end PRINTING_CHARACTER;

--
-- The input line editor
--  Customization can be done via the constant declarations
--
    procedure GET_LINE (INPUT_LINE : in out STRING) is

        WORK_LINE : STRING (1 .. INPUT_LINE'LAST);
        INCHAR    : CHARACTER;
        INDEX     : NATURAL;
        POSITION  : NATURAL;

        procedure BACKUP is -- erase previous character from display
        begin
            SYSDEP.PUT (ASCII.BS);
            SYSDEP.PUT (' ');
            SYSDEP.PUT (ASCII.BS);
        end BACKUP;

        procedure BACKUP_CHARACTER is -- backup over last char w/tab processing
            INCHAR          : CHARACTER;
            BACKUP_POSITION : NATURAL;
        begin
            INCHAR := WORK_LINE (INDEX); -- extract target character
            if INCHAR = ASCII.HT then    -- back up over tab
                -- compute position prior to this tab
                POSITION := 1;
                for I in 1 .. INDEX - 1 loop
                    if WORK_LINE (I) /= ASCII.HT then
                        POSITION := POSITION + 1;
                    else
                        POSITION := POSITION + 1;
                        while POSITION mod TAB_SIZE /= 1 loop
                            POSITION := POSITION + 1;
                        end loop;
                    end if;
                end loop;
                -- BACKUP required number of character positions
                BACKUP_POSITION := POSITION;
                BACKUP;
                BACKUP_POSITION := BACKUP_POSITION + 1;
                while BACKUP_POSITION mod TAB_SIZE /= 1 loop
                    BACKUP;
                    BACKUP_POSITION := BACKUP_POSITION + 1;
                end loop;
            else -- back up over normal char
                if PRINTING_CHARACTER (INCHAR) then
                    BACKUP;
                    POSITION := POSITION - 1;
                end if;
            end if;
        end BACKUP_CHARACTER;

        procedure STORE_CHARACTER (INCHAR : CHARACTER) is
        begin
            if INDEX < WORK_LINE'LAST then
                -- room for char
                WORK_LINE (INDEX) := INCHAR;
                INDEX := INDEX + 1;
            else
                -- no room
                SYSDEP.PUT (ASCII.BEL); -- alarm
            end if;
        end STORE_CHARACTER;

    begin
        INDEX := 1;
        POSITION := 1;
        loop
            SYSDEP.GET (INCHAR);
            exit when INCHAR = ASCII.CR;
            case INCHAR is
                when EDIT_DEL_CHAR =>  -- delete previous character
                    if INDEX /= 1 then
                        INDEX := INDEX - 1;
                        BACKUP_CHARACTER;
                    else
                        SYSDEP.PUT (ASCII.BEL);
                    end if;
                when EDIT_DEL_LINE =>  -- delete line typed so far
                    for I in 1 .. INDEX - 1 loop
                        INDEX := INDEX - 1;
                        BACKUP_CHARACTER;
                    end loop;
                    INDEX := 1;
                    POSITION := 1;
                when EDIT_RETYPE_LINE =>  -- retype line input so far
                    NEW_LINE; -- next line
                    WORK_LINE (INDEX) := ASCII.NUL; -- mark end of line
                    PUT (WORK_LINE);
                when EDIT_QUOTE =>  -- quote next char
                    SYSDEP.PUT (EDIT_QUOTE); -- echo EDIT_QUOTE char
                    POSITION := POSITION + 1; -- EDIT_QUOTE is printing char
                    SYSDEP.GET (INCHAR); -- get quoted char
                    STORE_CHARACTER (INCHAR);
                    if PRINTING_CHARACTER (INCHAR) then
                        SYSDEP.PUT (INCHAR); -- echo it
                        POSITION := POSITION + 1;
                    end if;
                when EDIT_TAB =>  -- tabulate
                    STORE_CHARACTER (INCHAR);
                    SYSDEP.PUT (' ');
                    POSITION := POSITION + 1;
                    while POSITION mod TAB_SIZE /= 1 loop
                        SYSDEP.PUT (' ');
                        POSITION := POSITION + 1;
                    end loop;
                when others =>  -- process next char
                    STORE_CHARACTER (INCHAR); -- store char
                    if PRINTING_CHARACTER (INCHAR) then
                        SYSDEP.PUT (INCHAR);
                        POSITION := POSITION + 1;
                    end if;
            end case;
        end loop;
        NEW_LINE;
--
-- NUL-fill line
--
        for I in INDEX .. WORK_LINE'LAST loop
            WORK_LINE (I) := ASCII.NUL;
        end loop;
--
-- return line and line length
--
        INPUT_LINE := WORK_LINE;
        GET_LINE_LENGTH := INDEX - 1;
--
    end GET_LINE;


--
-- GET_LINE like above but returns a character count also
--
    procedure GET_LINE (INPUT_LINE : in out STRING; LAST : out NATURAL) is
    begin
        GET_LINE (INPUT_LINE);
        LAST := GET_LINE_LENGTH;
    end GET_LINE;


--
-- LINE_LENGTH computes the length of the string (padded with ASCII.NULs)
--
    function LINE_LENGTH (INPUT_LINE : STRING) return NATURAL is
    begin
        for I in 1 .. INPUT_LINE'LAST loop
            if INPUT_LINE (I) = ASCII.NUL then
                return I - 1;
            end if;
        end loop;
        return INPUT_LINE'LAST;
    end LINE_LENGTH;


--
-- PUT outputs the string to the user's terminal.
--
    procedure PUT (STR : STRING) is

        INDEX    : NATURAL := 1;
        POSITION : NATURAL := 1;

    begin
        loop
            exit when INDEX > STR'LAST;
            exit when STR (INDEX) = ASCII.NUL;
            if STR (INDEX) = ASCII.HT then
                -- tabulate
                SYSDEP.PUT (' ');
                POSITION := POSITION + 1;
                while (POSITION mod TAB_SIZE) /= 1 loop
                    SYSDEP.PUT (' ');
                    POSITION := POSITION + 1;
                end loop;
            else
                -- output character
                SYSDEP.PUT (STR (INDEX));
                if PRINTING_CHARACTER (STR (INDEX)) then
                    POSITION := POSITION + 1;
                end if;
            end if;
            INDEX := INDEX + 1;
        end loop;
    end PUT;

--
-- NEW_LINE outputs CRLF to the user's terminal.
--
    procedure NEW_LINE is
    begin
        SYSDEP.PUT (ASCII.CR);
        SYSDEP.PUT (ASCII.LF);
    end NEW_LINE;


--
-- PUT_LINE outputs the string followed by a CRLF to the user's terminal.
--
    procedure PUT_LINE (STR : STRING) is
    begin
        PUT (STR);
        NEW_LINE;
    end PUT_LINE;


--
-- PUT outputs a character without processing
--
    procedure PUT (INCHAR : CHARACTER) is
    begin
        SYSDEP.PUT (INCHAR);
    end PUT;


--
-- GETC returns the next character without echo
--
    function GETC return CHARACTER is
        INCHAR : CHARACTER;
    begin
        if CHARACTER_IS_PENDING then
            INCHAR := PENDING_CHARACTER;
            CHARACTER_IS_PENDING := FALSE;
        else
            SYSDEP.GET (INCHAR);
        end if;
        return INCHAR;
    end GETC;


--
-- GETC as a procedure
--
    procedure GETC (CH : out CHARACTER) is
    begin
        CH := GETC;
    end GETC;


--
-- GETC_WITH_ECHO returns the next character and echoes it if > ' ' and < DEL
--
    function GETC_WITH_ECHO return CHARACTER is
        INCHAR : CHARACTER;
    begin
        INCHAR := GETC;
        if INCHAR >= ' ' and INCHAR < ASCII.DEL then
            SYSDEP.PUT (INCHAR);
        end if;
        return INCHAR;
    end GETC_WITH_ECHO;


--
-- GETC_WITH_ECHO as a procedure
--
    procedure GETC_WITH_ECHO (CH : out CHARACTER) is
    begin
        CH := GETC_WITH_ECHO;
    end GETC_WITH_ECHO;


--
-- UNGETC sets the next character to be returned by GETC or GETC_WITH_ECHO
--
    procedure UNGETC (INCHAR : CHARACTER) is
    begin
        CHARACTER_IS_PENDING := TRUE;
        PENDING_CHARACTER := INCHAR;
    end UNGETC;


end IO_SUPPORT;


::::::::::
TCHAR.ADA
::::::::::


--
-- Test for IO_SUPPORT Character-Oriented Routines
-- by Richard Conn, TI Ada Technology Branch
--
with IO_SUPPORT;
use IO_SUPPORT;
procedure TCHAR is

    INCHAR : CHARACTER;
    MYCHAR : CHARACTER;

begin
    CONSOLE_INIT;
    PUT_LINE ("Input characters -- RETURN to exit, . to test UNGETC");
    loop
        INCHAR := GETC;
        case INCHAR is
            when 'a' .. 'z' | 'A' .. 'Z' =>
                PUT ("Letter: ");
                PUT (INCHAR);
            when '0' .. '9' =>
                PUT ("Digit:  ");
                PUT (INCHAR);
            when '.' =>
                PUT ("Char to UNGETC? ");
                GETC_WITH_ECHO (MYCHAR);
                UNGETC (MYCHAR);
            when others =>
                if INCHAR >= ' ' and INCHAR < ASCII.DEL then
                    PUT ("        ");
                    PUT (INCHAR);
                else
                    PUT (ASCII.BEL);
                end if;
        end case;
        NEW_LINE;
        exit when INCHAR = ASCII.CR;
    end loop;
    PUT_LINE ("Done");
    CONSOLE_DEINIT;
end TCHAR;



::::::::::
TLINE.ADA
::::::::::


--
-- Test program for routines in IO_SUPPORT
-- by Richard Conn
--

with IO_SUPPORT;
use IO_SUPPORT;
procedure TLINE is

--
-- Variables
--
    MYLINE : STRING (1 .. 80);

--
-- Mainline
--
begin
    CONSOLE_INIT;
    PUT_LINE ("Input Lines and end test with a <RETURN>");
    loop
        PUT ("INPUT     > ");
        GET_LINE (MYLINE);
        exit when MYLINE (1) = ASCII.NUL;
        PUT (" OUT_LINE > ");
        PUT_LINE (MYLINE);
    end loop;
    PUT_LINE ("Done with Test");
    CONSOLE_DEINIT;
end TLINE;