home *** CD-ROM | disk | FTP | other *** search
/ SuperHack / SuperHack CD.bin / CODING / MISC / ADA_TUT3.ZIP / VAX.ADA < prev   
Encoding:
Text File  |  1994-08-22  |  4.8 KB  |  114 lines
  1. -- VAX.ADA   Ver. 3.00   22-AUG-1994   Copyright 1988-1994 John J. Herro
  2. -- Software Innovations Technology
  3. -- 1083 Mandarin Drive NE, Palm Bay, FL  32905-4706   (407)951-0233
  4. --
  5. -- Compile this before compiling ADA_TUTR.ADA with VAX Ada.  See first page of
  6. -- ADA_TUTR.ADA for more details.
  7. --
  8. package Custom_IO is
  9.    type Color is (Black, Red, Green, Yellow, Blue, Magenta, Cyan, White);
  10.    Foregrnd_Color   : Color := White;                 -- Default values in case
  11.    Backgrnd_Color   : Color := Black;                 -- ADA-TUTR finds no User
  12.    Border_Color     : Color := Black;                 -- File.
  13.    Fore_Color_Digit : Character := Character'Val(Color'Pos(Foregrnd_Color)+48);
  14.    Back_Color_Digit : Character := Character'Val(Color'Pos(Backgrnd_Color)+48);
  15.    Normal_Colors    : String(1 .. 10) := ASCII.ESC & "[0;3" &
  16.                               Fore_Color_Digit & ";4" & Back_Color_Digit & "m";
  17.    Clear_Scrn       : constant String := ASCII.ESC & "[H" & ASCII.ESC & "[2J";
  18.  
  19.    procedure Set_Border_Color (To   : in  Color);
  20.    procedure Get              (Char : out Character);
  21.    procedure Put              (Char : in  Character);
  22.    procedure Put              (Str  : in  String);
  23.    procedure Put_Line         (Str  : in  String);
  24.    procedure Get_Line         (Str  : out String; Last : out Natural);
  25.    procedure New_Line;
  26. end Custom_IO;
  27.  
  28. with Starlet, System; use Starlet, System;
  29. package body Custom_IO is
  30.    Chan : Starlet.Channel_Type;
  31.    IOSB : System.Unsigned_Quadword;
  32.    Stat : System.Unsigned_Longword;
  33.    procedure QIOW(Stat : out Unsigned_Longword; EFN : in Integer;
  34.         Chan : in Channel_Type; Func : in Short_Integer;
  35.         IOSB : out Unsigned_Quadword; ASTadr : in Integer; ASTPRM : in Integer;
  36.         P1 : in out String; P2, P3 : in Integer; P4 : in Unsigned_Quadword;
  37.         P5, P6 : in Integer);                   -- Pragma Interface is used for
  38.    pragma Interface(System_Library, QIOW);      -- compatibility with Ada 83.
  39.    pragma Import_Valued_Procedure(Internal => QIOW, External => "SYS$QIOW",
  40.         Parameter_Types => (Unsigned_Longword, Integer, Channel_Type,
  41.              Short_Integer, Unsigned_Quadword, Integer, Integer, String,
  42.              Integer, Integer, Unsigned_Quadword, Integer, Integer),
  43.         Mechanism => (Value, Value, Value, Value, Reference, Value, Reference,
  44.              Reference, Value, Reference, Reference, Reference, Reference));
  45.  
  46.    procedure Set_Border_Color(To : in Color) is
  47.       -- Dummy procedure for computers other than PCs.
  48.    begin
  49.       null;
  50.    end Set_Border_Color;
  51.  
  52.    procedure Get(Char : out Character) is
  53.       S : String(1 .. 1);
  54.    begin
  55.       QIOW(Stat, 0, Chan, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
  56.       Char := S(1);
  57.    end Get;
  58.  
  59.    procedure Put(Char : in Character) is
  60.    begin
  61.       Put(Char & "");
  62.    end PUT;
  63.  
  64.    procedure Put(Str : in String) is
  65.       S : String(Str'Range) := Str;
  66.    begin
  67.       QIOW(Stat, 0, Chan, 16#70#, IOSB, 0, 0, S, S'Length, 0, (0,0), 0, 0);
  68.    end PUT;
  69.  
  70.    procedure Put_Line(Str : in String) is
  71.    begin
  72.       Put(Str & ASCII.CR & ASCII.LF);
  73.    end Put_Line;
  74.  
  75.    procedure Get_Line(Str : out String; Last : out Natural) is separate;
  76.  
  77.    procedure New_Line is
  78.    begin
  79.       Put(ASCII.CR & ASCII.LF);
  80.    end New_Line;
  81. begin
  82.    Starlet.Assign(Stat, "TT:", Chan);
  83. end Custom_IO;
  84.  
  85. -- This procedure gets a string from the terminal, while allowing typing errors
  86. -- to be corrected.
  87. --
  88. separate (Custom_IO)
  89. procedure Get_Line(Str : out String; Last : out Natural) is
  90.    S     : String(Str'Range);                             -- Local copy of Str.
  91.    Char  : Character := ' ';                    -- One character from keyboard.
  92.    Place : Integer   := Str'First;     -- Position of next available character.
  93. begin
  94.    while Char /= ASCII.CR loop                   -- CR signifies end of string.
  95.       Get(Char);                                          -- Get one character.
  96.       if Char = ASCII.CR then
  97.          New_Line;                       -- Give new line at end of the string.
  98.       elsif Char = ASCII.BS or Char = ASCII.DEL then
  99.          if Place > Str'First then        -- Ignore BS/DEL when string is null.
  100.             Put(ASCII.BS & ' ' & ASCII.BS);   -- Erase last char. from display.
  101.             Place := Place - 1;               -- Remove last char. from string.
  102.          end if;
  103.       elsif Place > Str'Last then    -- Beep when length of string is exceeded.
  104.          Put(ASCII.BEL);
  105.       else
  106.          Put(Char);                                -- Echo the character typed.
  107.          S(Place) := Char;                      -- Add character to the string.
  108.          Place := Place + 1;
  109.       end if;
  110.    end loop;
  111.    Str(Str'First .. Place - 1) := S(Str'First .. Place - 1);
  112.    Last := Place - 1;
  113. end Get_Line;
  114.