home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / ada-tutr.lzh / MERIDIAN.ADA < prev    next >
Text File  |  1988-12-21  |  3KB  |  70 lines
  1. -- MERIDIAN.ADA   Ver. 1.20   21-DEC-1988
  2. -- Copyright 1988 John J. Herro
  3. -- Software Innovations Technology
  4. -- 1083 Mandarin Drive NE, Palm Bay, FL 32905-4706   (407)951-0233
  5. --
  6. -- Compile this before compiling ADA-TUTR.ADA, when using a PC with the
  7. -- Meridian AdaStarter or AdaVantage compiler and the DOS Environment Library.
  8. --
  9. with TTY;
  10. package CUSTOM_IO is
  11.    type COLOR is (BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE);
  12.    FOREGRND_COLOR   : COLOR := WHITE;                 -- Default values in case
  13.    BACKGRND_COLOR   : COLOR := BLACK;                 -- ADA-TUTR finds no User
  14.    BORDER_COLOR     : COLOR := BLACK;                 -- File.
  15.    FORE_COLOR_DIGIT : CHARACTER;             -- These three variables are given
  16.    BACK_COLOR_DIGIT : CHARACTER;             -- values in the initialization
  17.    NORMAL_COLORS    : STRING(1 .. 10);       -- section of the package body.
  18.    CLEAR_SCRN       : constant STRING := ASCII.ESC & "[H" & ASCII.ESC &"[2J";
  19.  
  20.    procedure SET_BORDER_COLOR (TO   : in COLOR);
  21.    procedure GET              (CHAR : out CHARACTER);
  22.    procedure PUT              (CHAR : in  CHARACTER) renames TTY.PUT;
  23.    procedure PUT              (STR  : in  STRING)    renames TTY.PUT;
  24.    procedure PUT_LINE         (STR  : in  STRING)    renames TTY.PUT_LINE;
  25.    procedure GET_LINE         (STR  : out STRING;
  26.                                LAST : out NATURAL)   renames TTY.GET;
  27.    procedure NEW_LINE;
  28. end CUSTOM_IO;
  29.  
  30. with INTERRUPT;
  31. package body CUSTOM_IO is
  32.    procedure SET_BORDER_COLOR(TO : in COLOR) is
  33.       --
  34.       -- This procedure sets the border color on a PC by calling interrupt
  35.       -- 10 hex.  Before the call, register AH is set to service number 0B hex,
  36.       -- BH is set to zero, and BL is set to an integer as shown in the
  37.       -- declaration of COLOR_NUMBER below.  Note that the integers in
  38.       -- COLOR_NUMBER are bit reversed from the integers defining foreground
  39.       -- and background colors in ANSI escape sequences.  Note also that some
  40.       -- color PCs don't have separate border colors.
  41.       --
  42.       REGIS_BLOCK  : INTERRUPT.REGISTERS;
  43.       COLOR_NUMBER : constant array(COLOR) of INTEGER :=
  44.           (BLACK   => 0,   RED     => 4,   GREEN   => 2,   YELLOW  => 6,
  45.            BLUE    => 1,   MAGENTA => 5,   CYAN    => 3,   WHITE   => 7);
  46.    begin
  47.       REGIS_BLOCK.AX := 16#0B00#;
  48.       REGIS_BLOCK.BX := 16#0000# + COLOR_NUMBER(TO);
  49.       INTERRUPT.VECTOR(ON => 16#10#, REGISTER_BLOCK => REGIS_BLOCK);
  50.    end SET_BORDER_COLOR;
  51.  
  52.    procedure GET(CHAR : out CHARACTER) is
  53.    begin
  54.       CHAR := TTY.GET;
  55.    end GET;
  56.  
  57.    procedure NEW_LINE is
  58.    begin
  59.       PUT_LINE("");
  60.    end NEW_LINE;
  61. begin
  62.    -- These variables are initialized here, rather than in the package
  63.    -- specification, to work around a minor bug in version 2.1 of the
  64.    -- Meridian AdaStarter compiler.
  65.    FORE_COLOR_DIGIT := CHARACTER'VAL(COLOR'POS(FOREGRND_COLOR) + 48);
  66.    BACK_COLOR_DIGIT := CHARACTER'VAL(COLOR'POS(BACKGRND_COLOR) + 48);
  67.    NORMAL_COLORS    := ASCII.ESC & "[0;3" & FORE_COLOR_DIGIT & ";4" &
  68.                             BACK_COLOR_DIGIT & "m";
  69. end CUSTOM_IO;
  70.