home *** CD-ROM | disk | FTP | other *** search
/ Hall of Fame / HallofFameCDROM.cdr / prog1 / ada-tutr.lzh / VAX.ADA < prev   
Text File  |  1988-12-21  |  5KB  |  115 lines

  1. -- VAX.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 with VAX Ada.  See first page of
  7. -- ADA-TUTR.ADA for more details.
  8. --
  9. package CUSTOM_IO is
  10.    type COLOR is (BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE);
  11.    FOREGRND_COLOR   : COLOR := WHITE;                 -- Default values in case
  12.    BACKGRND_COLOR   : COLOR := BLACK;                 -- ADA-TUTR finds no User
  13.    BORDER_COLOR     : COLOR := BLACK;                 -- File.
  14.    FORE_COLOR_DIGIT : CHARACTER := CHARACTER'VAL(COLOR'POS(FOREGRND_COLOR)+48);
  15.    BACK_COLOR_DIGIT : CHARACTER := CHARACTER'VAL(COLOR'POS(BACKGRND_COLOR)+48);
  16.    NORMAL_COLORS    : STRING(1 .. 10) := ASCII.ESC & "[0;3" &
  17.                               FORE_COLOR_DIGIT & ";4" & BACK_COLOR_DIGIT & "m";
  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);
  23.    procedure PUT              (STR  : in  STRING);
  24.    procedure PUT_LINE         (STR  : in  STRING);
  25.    procedure GET_LINE         (STR  : out STRING; LAST : out NATURAL);
  26.    procedure NEW_LINE;
  27. end CUSTOM_IO;
  28.  
  29. with STARLET, SYSTEM; use STARLET, SYSTEM;
  30. package body CUSTOM_IO is
  31.    CHAN : STARLET.CHANNEL_TYPE;
  32.    IOSB : SYSTEM.UNSIGNED_QUADWORD;
  33.    STAT : SYSTEM.UNSIGNED_LONGWORD;
  34.    procedure QIOW(STAT : out UNSIGNED_LONGWORD; EFN : in INTEGER;
  35.         CHAN : in CHANNEL_TYPE; FUNC : in SHORT_INTEGER;
  36.         IOSB : out UNSIGNED_QUADWORD; ASTADR : in INTEGER; ASTPRM : in INTEGER;
  37.         P1 : in out STRING; P2, P3 : in INTEGER; P4 : in UNSIGNED_QUADWORD;
  38.         P5, P6 : in INTEGER);
  39.    pragma INTERFACE(SYSTEM_LIBRARY, QIOW);
  40.    pragma IMPORT_VALUED_PROCEDURE(INTERNAL => QIOW, EXTERNAL => "SYS$QIOW",
  41.         PARAMETER_TYPES => (UNSIGNED_LONGWORD, INTEGER, CHANNEL_TYPE,
  42.              SHORT_INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER, STRING,
  43.              INTEGER, INTEGER, UNSIGNED_QUADWORD, INTEGER, INTEGER),
  44.         MECHANISM => (VALUE, VALUE, VALUE, VALUE, REFERENCE, VALUE, REFERENCE,
  45.              REFERENCE, VALUE, REFERENCE, REFERENCE, REFERENCE, REFERENCE));
  46.  
  47.    procedure SET_BORDER_COLOR(TO : in COLOR) is
  48.       -- Dummy procedure for computers other than PCs.
  49.    begin
  50.       null;
  51.    end SET_BORDER_COLOR;
  52.  
  53.    procedure GET(CHAR : out CHARACTER) is
  54.       S : STRING(1 .. 1);
  55.    begin
  56.       QIOW(STAT, 0, CHAN, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
  57.       CHAR := S(1);
  58.    end GET;
  59.  
  60.    procedure PUT(CHAR : in CHARACTER) is
  61.    begin
  62.       PUT(CHAR & "");
  63.    end PUT;
  64.  
  65.    procedure PUT(STR : in STRING) is
  66.       S : STRING(STR'RANGE) := STR;
  67.    begin
  68.       QIOW(STAT, 0, CHAN, 16#70#, IOSB, 0, 0, S, S'LENGTH, 0, (0,0), 0, 0);
  69.    end PUT;
  70.  
  71.    procedure PUT_LINE(STR : in STRING) is
  72.    begin
  73.       PUT(STR & ASCII.CR & ASCII.LF);
  74.    end PUT_LINE;
  75.  
  76.    procedure GET_LINE(STR : out STRING; LAST : out NATURAL) is separate;
  77.  
  78.    procedure NEW_LINE is
  79.    begin
  80.       PUT(ASCII.CR & ASCII.LF);
  81.    end NEW_LINE;
  82. begin
  83.    STARLET.ASSIGN(STAT, "TT:", CHAN);
  84. end CUSTOM_IO;
  85.  
  86. -- This procedure gets a string from the terminal, while allowing typing errors
  87. -- to be corrected.
  88. --
  89. separate (CUSTOM_IO)
  90. procedure GET_LINE(STR : out STRING; LAST : out NATURAL) is
  91.    S     : STRING(STR'RANGE);                             -- Local copy of STR.
  92.    CHAR  : CHARACTER := ' ';                    -- One character from keyboard.
  93.    PLACE : INTEGER   := STR'FIRST;     -- Position of next available character.
  94. begin
  95.    while CHAR /= ASCII.CR loop                   -- CR signifies end of string.
  96.       GET(CHAR);                                          -- Get one character.
  97.       if CHAR = ASCII.CR then
  98.          NEW_LINE;                       -- Give new line at end of the string.
  99.       elsif CHAR = ASCII.BS or CHAR = ASCII.DEL then
  100.          if PLACE > STR'FIRST then        -- Ignore BS/DEL when string is null.
  101.             PUT(ASCII.BS & ' ' & ASCII.BS);   -- Erase last char. from display.
  102.             PLACE := PLACE - 1;               -- Remove last char. from string.
  103.          end if;
  104.       elsif PLACE > STR'LAST then    -- Beep when length of string is exceeded.
  105.          PUT(ASCII.BEL);
  106.       else
  107.          PUT(CHAR);                                -- Echo the character typed.
  108.          S(PLACE) := CHAR;                      -- Add character to the string.
  109.          PLACE := PLACE + 1;
  110.       end if;
  111.    end loop;
  112.    STR(STR'FIRST .. PLACE - 1) := S(STR'FIRST .. PLACE - 1);
  113.    LAST := PLACE - 1;
  114. end GET_LINE;
  115.