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

Text File | 1988-05-03 | 9.5 KB | 266 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : generic package SAFE_IO
-- Version      : 1.0
-- Author       : John A. Anderson
--              : TEXAS INSTRUMENTS MS 8006
--              : P.O. BOX 801
--              : MCKINNEY, TEXAS   75069
-- DDN Address  : ANDERSON%TI-EG@CSNET-RELAY
-- Copyright    : (c) 1984 John A. Anderson
-- Date created :  OCTOBER  2, 1984
-- Release date :  NOVEMBER 27, 1984
-- Last update  :  ANDERSON Wed Nov 27, 1984
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  INPUT/OUTPUT
--
-- Abstract     :  This generic package allows the user to
----------------:  input data types from the keyboard
----------------:  while checking the input for errors. (Proper
----------------:  Type:  syntax and ranges.)
----------------:  A procedure for checking input of characters
----------------:  for a proper subrange of the character set is
----------------:  provided.
----------------:  When an error is encountered, an error message
----------------:  is displayed and the user is allowed to reenter.
----------------:  Output routines are provided to allow the user
----------------:  to do I/O with only one instantiation.  Screen
----------------:  manipulation (i.e. NEW_LINE) should be done with
----------------:  TEXT_IO directly.
----------------:  Instantiations require a FIELD_WIDTH which
----------------:  specifies the maximum field width for the input
----------------:  of the corresponding type.
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 11/27/84      1.0    Anderson        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--------------------------------

with TEXT_IO;
package SAFE_IO is

    generic
        FIELD_WIDTH : INTEGER;
        type ITEM is range <>;
    package INTEGER_IO is
        procedure GET (ELEMENT : out ITEM);
        procedure PUT (ELEMENT : ITEM);
    end INTEGER_IO;

    generic
        FIELD_WIDTH : INTEGER;
        type ITEM is (<>);
    package ENUMERATION_IO is
        procedure GET (ELEMENT : out ITEM);
        procedure PUT (ELEMENT : ITEM);
    end ENUMERATION_IO;

    generic
        FIELD_WIDTH : INTEGER;
        type ITEM is delta <>;
    package FIXED_IO is
        procedure GET (ELEMENT : out ITEM);
        procedure PUT (ELEMENT : ITEM);
    end FIXED_IO;

    generic
        FIELD_WIDTH : INTEGER;
        type ITEM is digits <>;
    package FLOAT_IO is
        procedure GET (ELEMENT : out ITEM);
        procedure PUT (ELEMENT : ITEM);
    end FLOAT_IO;

    generic
        FIRST : CHARACTER;
        LAST  : CHARACTER;
    procedure GET_CHAR (ELEMENT : out CHARACTER);

end SAFE_IO;


package body SAFE_IO is

    procedure GET_CHAR (ELEMENT : out CHARACTER) is
        subtype ITEM is CHARACTER range FIRST .. LAST;
        LOCAL : ITEM;
    begin
        MAIN:
        loop
            begin
                TEXT_IO.GET (LOCAL);
                ELEMENT := LOCAL;
                exit;
            exception
                when TEXT_IO.DATA_ERROR =>
                    TEXT_IO.PUT_LINE ("ERROR, Please Re-Enter:");
                    TEXT_IO.SKIP_LINE;
                when CONSTRAINT_ERROR =>
                    TEXT_IO.PUT_LINE ("ERROR, Please Re-Enter");
            end;
        end loop MAIN;
    end GET_CHAR;

    package body INTEGER_IO is
        package NORM_IO is new TEXT_IO.INTEGER_IO (ITEM);
        procedure GET (ELEMENT : out ITEM) is
            subtype MYSTRING is STRING (1 .. FIELD_WIDTH);
            SOMETHING : MYSTRING;
            LAST      : INTEGER;
        begin
            MAIN:
            loop
                begin
                    SOMETHING := (1 .. FIELD_WIDTH => ' ');
                    TEXT_IO.GET_LINE (SOMETHING, LAST);
                    ELEMENT := ITEM'VALUE (SOMETHING);
                    exit;
                exception
                    when CONSTRAINT_ERROR =>
                        TEXT_IO.PUT_LINE ("ERROR, Please Re-Enter:");
                end;
            end loop MAIN;
        end GET;

        procedure PUT (ELEMENT : ITEM) is
        begin
            NORM_IO.PUT (ELEMENT);
        end PUT;
    end INTEGER_IO;

    package body ENUMERATION_IO is
        package NORM_IO is new TEXT_IO.ENUMERATION_IO (ITEM);
        procedure GET (ELEMENT : out ITEM) is
            subtype MYSTRING is STRING (1 .. FIELD_WIDTH);
            SOMETHING : MYSTRING;
            LAST      : INTEGER;
        begin
            MAIN:
            loop
                begin
                    SOMETHING := (1 .. FIELD_WIDTH => ' ');
                    TEXT_IO.GET_LINE (SOMETHING, LAST);
                    ELEMENT := ITEM'VALUE (SOMETHING);
                    exit;
                exception
                    when CONSTRAINT_ERROR =>
                        TEXT_IO.PUT_LINE ("ERROR, Please Re-Enter:");
                end;
            end loop MAIN;
        end GET;

        procedure PUT (ELEMENT : ITEM) is
        begin
            NORM_IO.PUT (ELEMENT);
        end PUT;
    end ENUMERATION_IO;

    package body FIXED_IO is
        package NORM_IO is new TEXT_IO.FIXED_IO (ITEM);
        procedure GET (ELEMENT : out ITEM) is
            subtype MYSTRING is STRING (1 .. FIELD_WIDTH);
            SOMETHING : MYSTRING;
            LAST1     : INTEGER;
            LAST2     : INTEGER;
            EXTRA_CHARACTERS : exception;
        begin
            MAIN:
            loop
                begin
                    SOMETHING := (1 .. FIELD_WIDTH => ' ');
                    TEXT_IO.GET_LINE (SOMETHING, LAST1);
                    NORM_IO.GET (SOMETHING, ELEMENT, LAST2);
                    if LAST1 > LAST2 then
                        for INDEX in (LAST2 + 1) .. LAST1 loop
                            if SOMETHING (INDEX) /= ' ' then
                                raise EXTRA_CHARACTERS;
                            end if;
                        end loop;
                    end if;
                    exit;
                exception
                    when others =>
                        TEXT_IO.PUT_LINE ("ERROR, Please Re-Enter:");
                end;
            end loop MAIN;
        end GET;

        procedure PUT (ELEMENT : ITEM) is
        begin
            NORM_IO.PUT (ELEMENT);
        end PUT;
    end FIXED_IO;

    package body FLOAT_IO is
        package NORM_IO is new TEXT_IO.FLOAT_IO (ITEM);
        procedure GET (ELEMENT : out ITEM) is
            subtype MYSTRING is STRING (1 .. FIELD_WIDTH);
            SOMETHING : MYSTRING;
            LAST1     : INTEGER;
            LAST2     : INTEGER;
            EXTRA_CHARACTERS : exception;
        begin
            MAIN:
            loop
                begin
                    SOMETHING := (1 .. FIELD_WIDTH => ' ');
                    TEXT_IO.GET_LINE (SOMETHING, LAST1);
                    NORM_IO.GET (SOMETHING, ELEMENT, LAST2);
                    if LAST1 > LAST2 then
                        for INDEX in (LAST2 + 1) .. LAST1 loop
                            if SOMETHING (INDEX) /= ' ' then
                                raise EXTRA_CHARACTERS;
                            end if;
                        end loop;
                    end if;
                    exit;
                exception
                    when others =>
                        TEXT_IO.PUT_LINE ("ERROR, Please Re-Enter:");
                end;
            end loop MAIN;
        end GET;

        procedure PUT (ELEMENT : ITEM) is
        begin
            NORM_IO.PUT (ELEMENT);
        end PUT;
    end FLOAT_IO;
end SAFE_IO;