-- VAX.ADA   Ver. 1.20   21-DEC-1988
-- Copyright 1988 John J. Herro
-- Software Innovations Technology
-- 1083 Mandarin Drive NE, Palm Bay, FL 32905-4706   (407)951-0233
--
-- Compile this before compiling ADA-TUTR.ADA with VAX Ada.  See first page of
-- ADA-TUTR.ADA for more details.
--
package CUSTOM_IO is
   type COLOR is (BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE);
   FOREGRND_COLOR   : COLOR := WHITE;                 -- Default values in case
   BACKGRND_COLOR   : COLOR := BLACK;                 -- ADA-TUTR finds no User
   BORDER_COLOR     : COLOR := BLACK;                 -- File.
   FORE_COLOR_DIGIT : CHARACTER := CHARACTER'VAL(COLOR'POS(FOREGRND_COLOR)+48);
   BACK_COLOR_DIGIT : CHARACTER := CHARACTER'VAL(COLOR'POS(BACKGRND_COLOR)+48);
   NORMAL_COLORS    : STRING(1 .. 10) := ASCII.ESC & "[0;3" &
                              FORE_COLOR_DIGIT & ";4" & BACK_COLOR_DIGIT & "m";
   CLEAR_SCRN       : constant STRING := ASCII.ESC & "[H" & ASCII.ESC & "[2J";

   procedure SET_BORDER_COLOR (TO   : in COLOR);
   procedure GET              (CHAR : out CHARACTER);
   procedure PUT              (CHAR : in  CHARACTER);
   procedure PUT              (STR  : in  STRING);
   procedure PUT_LINE         (STR  : in  STRING);
   procedure GET_LINE         (STR  : out STRING; LAST : out NATURAL);
   procedure NEW_LINE;
end CUSTOM_IO;

with STARLET, SYSTEM; use STARLET, SYSTEM;
package body CUSTOM_IO is
   CHAN : STARLET.CHANNEL_TYPE;
   IOSB : SYSTEM.UNSIGNED_QUADWORD;
   STAT : SYSTEM.UNSIGNED_LONGWORD;
   procedure QIOW(STAT : out UNSIGNED_LONGWORD; EFN : in INTEGER;
        CHAN : in CHANNEL_TYPE; FUNC : in SHORT_INTEGER;
        IOSB : out UNSIGNED_QUADWORD; ASTADR : in INTEGER; ASTPRM : in INTEGER;
        P1 : in out STRING; P2, P3 : in INTEGER; P4 : in UNSIGNED_QUADWORD;
        P5, P6 : in INTEGER);
   pragma INTERFACE(SYSTEM_LIBRARY, QIOW);
   pragma IMPORT_VALUED_PROCEDURE(INTERNAL => QIOW, EXTERNAL => "SYS$QIOW",
        PARAMETER_TYPES => (UNSIGNED_LONGWORD, INTEGER, CHANNEL_TYPE,
             SHORT_INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER, STRING,
             INTEGER, INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER),
        MECHANISM => (VALUE, VALUE, VALUE, VALUE, REFERENCE, VALUE, REFERENCE,
             REFERENCE, VALUE, REFERENCE, REFERENCE, REFERENCE, REFERENCE));

   procedure SET_BORDER_COLOR(TO : in COLOR) is
      -- Dummy procedure for computers other than PCs.
   begin
      null;
   end SET_BORDER_COLOR;

   procedure GET(CHAR : out CHARACTER) is
      S : STRING(1 .. 1);
   begin
      QIOW(STAT, 0, CHAN, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
      CHAR := S(1);
   end GET;

   procedure PUT(CHAR : in CHARACTER) is
   begin
      PUT(CHAR & "");
   end PUT;

   procedure PUT(STR : in STRING) is
      S : STRING(STR'RANGE) := STR;
   begin
      QIOW(STAT, 0, CHAN, 16#70#, IOSB, 0, 0, S, S'LENGTH, 0, (0,0), 0, 0);
   end PUT;

   procedure PUT_LINE(STR : in STRING) is
   begin
      PUT(STR & ASCII.CR & ASCII.LF);
   end PUT_LINE;

   procedure GET_LINE(STR : out STRING; LAST : out NATURAL) is separate;

   procedure NEW_LINE is
   begin
      PUT(ASCII.CR & ASCII.LF);
   end NEW_LINE;
begin
   STARLET.ASSIGN(STAT, "TT:", CHAN);
end CUSTOM_IO;

-- This procedure gets a string from the terminal, while allowing typing errors
-- to be corrected.
--
separate (CUSTOM_IO)
procedure GET_LINE(STR : out STRING; LAST : out NATURAL) is
   S     : STRING(STR'RANGE);                             -- Local copy of STR.
   CHAR  : CHARACTER := ' ';                    -- One character from keyboard.
   PLACE : INTEGER   := STR'FIRST;     -- Position of next available character.
begin
   while CHAR /= ASCII.CR loop                   -- CR signifies end of string.
      GET(CHAR);                                          -- Get one character.
      if CHAR = ASCII.CR then
         NEW_LINE;                       -- Give new line at end of the string.
      elsif CHAR = ASCII.BS or CHAR = ASCII.DEL then
         if PLACE > STR'FIRST then        -- Ignore BS/DEL when string is null.
            PUT(ASCII.BS & ' ' & ASCII.BS);   -- Erase last char. from display.
            PLACE := PLACE - 1;               -- Remove last char. from string.
         end if;
      elsif PLACE > STR'LAST then    -- Beep when length of string is exceeded.
         PUT(ASCII.BEL);
      else
         PUT(CHAR);                                -- Echo the character typed.
         S(PLACE) := CHAR;                      -- Add character to the string.
         PLACE := PLACE + 1;
      end if;
   end loop;
   STR(STR'FIRST .. PLACE - 1) := S(STR'FIRST .. PLACE - 1);
   LAST := PLACE - 1;
end GET_LINE;