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

-- MERIDIAN.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, when using a PC with the
-- Meridian AdaStarter or AdaVantage compiler and the DOS Environment Library.
--
with TTY;
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; -- These three variables are given
BACK_COLOR_DIGIT : CHARACTER; -- values in the initialization
NORMAL_COLORS : STRING(1 .. 10); -- section of the package body.
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) renames TTY.PUT;
procedure PUT (STR : in STRING) renames TTY.PUT;
procedure PUT_LINE (STR : in STRING) renames TTY.PUT_LINE;
procedure GET_LINE (STR : out STRING;
LAST : out NATURAL) renames TTY.GET;
procedure NEW_LINE;
end CUSTOM_IO;

with INTERRUPT;
package body CUSTOM_IO is
procedure SET_BORDER_COLOR(TO : in COLOR) is
--
-- This procedure sets the border color on a PC by calling interrupt
-- 10 hex. Before the call, register AH is set to service number 0B hex,
-- BH is set to zero, and BL is set to an integer as shown in the
-- declaration of COLOR_NUMBER below. Note that the integers in
-- COLOR_NUMBER are bit reversed from the integers defining foreground
-- and background colors in ANSI escape sequences. Note also that some
-- color PCs don't have separate border colors.
--
REGIS_BLOCK : INTERRUPT.REGISTERS;
COLOR_NUMBER : constant array(COLOR) of INTEGER :=
(BLACK => 0, RED => 4, GREEN => 2, YELLOW => 6,
BLUE => 1, MAGENTA => 5, CYAN => 3, WHITE => 7);
begin
REGIS_BLOCK.AX := 16#0B00#;
REGIS_BLOCK.BX := 16#0000# + COLOR_NUMBER(TO);
INTERRUPT.VECTOR(ON => 16#10#, REGISTER_BLOCK => REGIS_BLOCK);
end SET_BORDER_COLOR;

procedure GET(CHAR : out CHARACTER) is
begin
CHAR := TTY.GET;
end GET;

procedure NEW_LINE is
begin
PUT_LINE("");
end NEW_LINE;
begin
-- These variables are initialized here, rather than in the package
-- specification, to work around a minor bug in version 2.1 of the
-- Meridian AdaStarter compiler.
FORE_COLOR_DIGIT := CHARACTER'VAL(COLOR'POS(FOREGRND_COLOR) + 48);
BACK_COLOR_DIGIT := CHARACTER'VAL(COLOR'POS(BACKGRND_COLOR) + 48);
NORMAL_COLORS := ASCII.ESC & "[0;3" & FORE_COLOR_DIGIT & ";4" &
BACK_COLOR_DIGIT & "m";
end CUSTOM_IO;