Category : Miscellaneous Language Source Code
Archive   : ADATUT12.ZIP
Filename : VAX.ADA

-- 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 := BLUE; -- ADA-TUTR finds no User
BORDER_COLOR : COLOR := BLUE; -- 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;