Trailing-Edge
-
PDP-10 Archives
-
tops10_tools_bb-fp64b-sb
-
10,7/amis/input.pas
There are no other files named input.pas in the archive.
(* AMIS keybord input module. *) (* -*-PASCAL-*- *)
(****************************************************************************)
(* *)
(* Copyright (C) 1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987 by *)
(* Stacken, Royal Institute Of Technology, Stockholm, Sweden. *)
(* All rights reserved. *)
(* *)
(* This software is furnished under a license and may be used and copied *)
(* only in accordance with the terms of such license and with the *)
(* inclusion of the above copyright notice. This software or any other *)
(* copies thereof may not be provided or otherwise made available to any *)
(* other person. No title to and ownership of the software is hereby *)
(* transferred. *)
(* *)
(* The information in this software is subject to change without notice *)
(* and should not be construed as a commitment by Stacken. *)
(* *)
(* Stacken assumes no responsibility for the use or reliability of its *)
(* software on equipment which is not supported by Stacken. *)
(* *)
(****************************************************************************)
(*$E+,T-*) (* Compiler directives. *)
module input;
const
CtrlAtSign = 0; CtrlA = 1; CtrlB = 2;
CtrlC = 3; CtrlD = 4; CtrlE = 5;
CtrlF = 6; CtrlG = 7; CtrlH = 8;
CtrlI = 9; CtrlJ = 10; CtrlK = 11;
CtrlL = 12; CtrlM = 13; CtrlN = 14;
CtrlO = 15; CtrlP = 16; CtrlQ = 17;
CtrlR = 18; CtrlS = 19; CtrlT = 20;
CtrlU = 21; CtrlV = 22; CtrlW = 23;
CtrlX = 24; CtrlY = 25; CtrlZ = 26;
CtrlLeftBracket = 27; CtrlBackSlash = 28; CtrlRightBracket = 29;
CtrlUpArrow = 30; CtrlUnderScore = 31; RubOut = 127;
Null = CtrlAtSign; Bell = CtrlG; BackSpace = CtrlH;
HorizontalTab = CtrlI; LineFeed = CtrlJ; FormFeed = CtrlL;
CarriageReturn = CtrlM; Escape = CtrlLeftBracket;
HelpChar = CtrlUnderScore;
CSI = 155; (* Command Seq. introducer. *)
StrSize = 40;
(*@VMS: MacMax = 200; *) (* Max length of Keyboard macro *)
(*@TOPS: MacMax = 50; *) (* Max length of Keyboard macro *)
type
string = packed array [1..StrSize] of char;
RefMacro = ^MacroRecord;
MacroRecord = packed record
Left, Right : RefMacro; (* Links in linked list *)
Number : integer; (* Number of macro *)
Size : integer; (* Number of chars in macro *)
MacString : array [1..MacMax] of integer; (* Macro itself. *)
Running : boolean; (* If this macro is running *)
LoopCount : integer; (* Loopcounter for this run *)
Pos : integer; (* Position for this loop *)
end;
var
LastChar : char; (* The last character read *)
MetaChar : boolean; (* The last character was a meta-character *)
CsiTerminator : char; (* Character terminating CSI seq. *)
CsiArgument : integer; (* Numeric arg in CSI seq. *)
Again : boolean; (* We should read the last character again *)
Filing : boolean; (* We are reading from the init file *)
FilPos : integer; (* Position in init file *)
FilSiz : integer; (* Size of init file. *)
MacroRunning : boolean; (* A Keyboard macro is running *)
DefiningMacro : boolean; (* A Keyboard macro is being defined *)
ZeroMacro : RefMacro; (* Points to head of kbd macro linked list *)
RecLevel : integer; (* Recursion level for keyboard macros *)
LastFrozen : integer; (* Number of last frozen keybord macro *)
CurrentMacro : RefMacro; (* Points to currently running kbd macro *)
AutoBuffer : string; (* Auto echo buffer. *)
AutoCount : integer; (* Count of chars in auto echo buffer. *)
AutoStarted : boolean; (* Auto echo has started. *)
AutoEchoed : boolean; (* Current char is queued for echoing. *)
(*---------------------------------------------------------------------------*)
function TtyRead: integer; external;
procedure TtyFlush; external;
function TtyCheck(Seconds: integer): boolean; external;
procedure NoInt; external;
procedure OKInt; external;
procedure Bug(Msg: string); external;
procedure Error(Msg: string); external;
procedure DefMode(flag: boolean); external;
procedure CommandLoop(RecursiveName: string); external;
procedure TopLoop; external;
procedure EchoUpDate; external;
procedure WinUpDate; external;
procedure EchoSize(var x, y: integer); external;
procedure EchoPos(x, y: integer); external;
procedure EchoEol; external;
procedure EchoArrow(c: char); external;
procedure EchoString(s: string); external;
procedure WinOverWrite(c: char); external;
procedure OvWString(s: string); external;
procedure OvWLine; external;
function QGetChar(reg, dot: integer): char; external;
function QGetSize(reg: integer): integer; external;
procedure QX(reg, count: integer); external;
procedure EchoClear; forward; (* Until it is moved to SCREEN. *)
(*---------------------------------------------------------------------------*)
(* Automagical echo routines. *)
procedure AutoDump;
var
i: integer;
begin
for i := 1 to AutoCount do begin
AutoStarted := true;
EchoArrow(AutoBuffer[i])
end;
AutoCount := 0;
end;
(*@VMS: [global] *)
procedure AutoImmediate;
begin
if AutoCount > 0 then AutoDump;
AutoStarted := true;
end;
(*@VMS: [global] *)
procedure AutoReset;
begin
if AutoStarted (* If any echoing was written out *)
then EchoClear; (* Clear the echo area *)
AutoStarted := false; (* Reset flag *)
AutoCount := 0; (* Reset buffer count *)
end;
(*@VMS: [global] *)
procedure AutoChar(c: char);
begin
if AutoCount >= StrSize then AutoDump;
if AutoStarted then begin
EchoArrow(c);
end else begin
AutoCount := AutoCount + 1;
AutoBuffer [AutoCount] := c;
end;
end;
(*@VMS: [global] *)
procedure AutoLast(expand: boolean);
type word = packed array[1..10] of char;
procedure AutoWord(w: word);
var
i: integer;
begin
for i := 1 to 10 do if w[i] <> ' ' then AutoChar(w[i]);
AutoChar(' ');
end;
begin
if not AutoEchoed then begin
AutoEchoed := true;
if MetaChar then begin
AutoChar('M'); AutoChar('-')
end;
if LastChar = chr(BackSpace) then AutoWord('Backspace ')
else if LastChar = chr(HorizontalTab) then AutoWord('Tab ')
else if LastChar = chr(LineFeed) then AutoWord('Linefeed ')
else if LastChar = chr(CarriageReturn) then AutoWord('Return ')
else if LastChar = chr(Escape) then AutoWord('Escape ')
else if LastChar = chr(HelpChar) then AutoWord('Help ')
else if LastChar = ' ' then AutoWord('Space ')
else if LastChar = chr(Rubout) then AutoWord('Rubout ')
else if (LastChar < ' ') and expand then begin
AutoChar('C'); AutoChar('-');
AutoChar(chr(ord(LastChar) + 64)); AutoChar(' ');
end else begin
AutoChar(LastChar); AutoChar(' ');
end;
if AutoStarted then EchoUpDate;
end;
end;
(*---------------------------------------------------------------------------*)
(* Check for TTY input *)
(*@VMS: [global] *)
function Check(Time: integer): boolean;
begin
Check := Again or filing or MacroRunning or TtyCheck(Time);
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
procedure SetFile;
begin
FilPos:=0;
FilSiz:=QGetSize(-39);
Filing:=FilSiz>0;
end;
function nextfile: integer;
var
i: integer;
begin
i:=ord(QGetChar(-39,FilPos));
FilPos:=FilPos+1;
nextfile:=i;
if i = 13 then begin
if FilSiz>FilPos then i:=ord(QGetChar(-39,FilPos));
if i = 10 then FilPos:=FilPos+1;
end;
filing:=FilSiz>FilPos;
if not filing then QX(-39,0);
end;
(*---------------------------------------------------------------------------*)
(* The function NextMacro returns the next eight bit character from the *)
(* current running keybord macro. *)
function NextMacro: integer;
begin
with CurrentMacro^ do begin
if Pos > Size
then Bug('INPUT: No end of Keyboard macro. ');
NextMacro := MacString [Pos];
Pos := Pos + 1;
end; (* with *)
end;
(*---------------------------------------------------------------------------*)
(* The procedure NoMacDef aborts the current macro definition, if any. *)
procedure NoMacDef;
begin
DefMode(false);
DefiningMacro := false;
end;
(*---------------------------------------------------------------------------*)
(* The procedure KbdStart implements the function ^R Start Kbd Macro. *)
(*@VMS: [global] *)
procedure KbdStart(Arg: integer);
begin
if DefiningMacro or MacroRunning
then begin (* May not be started inside another *)
NoMacDef;
Error('RKM? Recursive Keyboard macro ')
end;
if RecLevel > 0 (* Not allowed below a Kbd Macro Query *)
then Error('MIR? But the macro is running ');
with ZeroMacro^ do begin
Size := 0;
LoopCount := arg;
end; (* with *)
CurrentMacro := ZeroMacro;
DefiningMacro := true; (* Now we are definig a macro. *)
defmode(true); (* ... tell MAIN for the modeline *)
end;
(*---------------------------------------------------------------------------*)
(* The procedure KbdEnd implements the function ^R End Kbd Macro. *)
(*@VMS: [global] *)
procedure KbdEnd(Arg: integer; ArgGiven: boolean);
begin
if not (MacroRunning or DefiningMacro)
then Error('NIB? Not inside a macro. ');
with CurrentMacro^ do begin
if (DefiningMacro and ArgGiven)
then LoopCount := Arg;
Pos := 1; (* Restart the macro *)
LoopCount := LoopCount - 1;
MacroRunning := (LoopCount <> 0);
end; (* with *)
NoMacDef;
end;
(*---------------------------------------------------------------------------*)
function FindKbdMacro(Number: integer): RefMacro;
var
Test: RefMacro;
begin
Test := ZeroMacro;
if Number <> 0
then repeat
Test := Test^.Right;
if Test = ZeroMacro
then Bug('FindKbdMacro: Illegal argument. ');
until Test^.Number = Number;
FindKbdMacro := Test;
end;
(*---------------------------------------------------------------------------*)
(* This procedure does the job of the function ^R Execute Kbd Macro. *)
(*@VMS: [global] *)
procedure KbdExecute(Number, Arg: integer);
begin
if DefiningMacro or MacroRunning
then begin
NoMacDef;
Error('RKM? Recursive Keyboard macro ');
end;
if RecLevel > 0
then Error('MIR? But the macro is running ');
CurrentMacro := FindKbdMacro(Number);
with CurrentMacro^ do begin
if Size = 0 then Error('NMD? No Keyboard Macro is defined. ');
Pos := 1;
LoopCount := Arg; (* Do it arg times *)
MacroRunning := true;
end; (* with *)
end;
(*---------------------------------------------------------------------------*)
(* The procedure KbdView implements the function View Kbd Macro. *)
(*@VMS: [global] *)
procedure KbdView(Number: integer);
var
i: integer;
c: char;
m: RefMacro;
begin
OvWString('Definition of keyboard macro: ');
OvWLine; OvWLine;
m := FindKbdMacro(Number);
with m^ do begin
for i := 1 to Size do begin
c := chr(MacString [i] mod 128);
if (c < ' ') and (c <> chr(Escape)) and (c <> chr(CarriageReturn)) and
(c <> chr(HorizontalTab)) then
begin
WinOverWrite('C'); WinOverWrite('-');
c := chr(ord(c) + 64); (* Convert to writeable character *)
end;
if macstring [i] > 127
then begin
WinOverWrite('M'); WinOverWrite('-')
end;
if c = chr(Escape)
then OvWString('Escape ')
else if c = ' '
then OvWString('Space ')
else if c = chr(CarriageReturn)
then OvWString('Return ')
else if c = chr(HorizontalTab)
then OvWString('Tab ')
else if c = chr(Rubout)
then OvWString('Rubout ')
else begin
WinOverWrite(c); WinOverWrite(' ');
end;
end; (* for *)
end; (* with *)
OvWLine;
end;
(*---------------------------------------------------------------------------*)
(* The function KbdFreeze saves the currently defined macro, and returns *)
(* a handle for later access. *)
(*@VMS: [global] *)
function KbdFreeze: integer;
var
ThisMacro: RefMacro;
begin (* KbdFreeze *)
NoInt; (* Lock out interrupts *)
LastFrozen := LastFrozen + 1;
new(ThisMacro);
with ThisMacro^ do begin
Left := ZeroMacro;
Right := ZeroMacro^.Right;
MacString := ZeroMacro^.MacString;
Size := ZeroMacro^.Size;
Number := LastFrozen;
end; (* with *)
ZeroMacro^.Right := ThisMacro;
ZeroMacro^.Right^.Left := ThisMacro;
KbdFreeze := LastFrozen;
OKInt; (* Allow interrupts again *)
end; (* KbdFreeze *)
(*---------------------------------------------------------------------------*)
(* The function KbdStop aborts macro definition, if any, and returns true *)
(* if there was a macro being defined. *)
(*@VMS: [global] *)
function KbdStop: boolean;
begin
NoMacDef;
RecLevel := 0;
KbdStop := MacroRunning;
MacroRunning := false;
end;
(*---------------------------------------------------------------------------*)
(* The function KbdRunning checks if a Keybord macro is running. *)
(*@VMS: [global] *)
function KbdRunning: boolean;
begin
KbdRunning := MacroRunning;
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
procedure GetCsiData(var arg: integer; var tc: char);
begin
arg := CsiArgument;
tc := CsiTerminator;
end;
(*---------------------------------------------------------------------------*)
(* This function is the basic character reading routine. *)
(*@VMS: [global] *)
function QReadC: char;
var
i: integer;
procedure MacroSave;
begin
with ZeroMacro^ do begin
Size := Size + 1;
if Size > MacMax then begin (* Flush this macro if too long. *)
Size := 0;
Error('TLK? Too Long Keyboard macro ');
end;
MacString [Size] := i;
end; (* with *)
end;
begin
if not Again then begin
if MacroRunning
then i := nextmacro
else begin
if filing
then i := nextfile
else begin
if AutoCount > 0 then (* Any lazy echo? *)
if not check(1) then begin (* Yes, input within a second? *)
AutoDump; (* No, dump out all echos *)
EchoUpDate; (* Force it out *)
end;
i := TtyRead; (* Get a character from the user *)
end;
if DefiningMacro then MacroSave;
end;
if i = CSI then begin (* Parse CSI arguments, if any. *)
CsiArgument := 0;
while QReadC in ['0'..'9'] do begin
CsiArgument := CsiArgument * 10 + ord(LastChar) - ord('0');
end;
CsiTerminator := LastChar;
end;
AutoEchoed := false; (* This char is not echoed yet. *)
LastChar := chr(i mod 256); (* Split into character and meta bit. *)
MetaChar := i >= 256;
end;
Again := false; (* Don't read this again unless told so *)
QReadC := LastChar;
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
function ReadC: char;
begin
ReadC := QReadC; (* Read a character *)
if LastChar = chr(CtrlG) (* Is it a ^G? *)
then begin (* Yes, abort if not meta bit on *)
if not MetaChar
then TopLoop;
end;
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
function MetaBit: boolean;
begin
MetaBit := MetaChar;
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
procedure ReRead;
begin (* Read last character again *)
Again := true;
end;
(*---------------------------------------------------------------------------*)
(*@VMS: [global] *)
procedure Flush;
begin (* Flush all TTY buffers *)
Again := false;
TtyFlush;
end;
(*---------------------------------------------------------------------------*)
(* This procedure implements the function ^R Kbd Macro Query *)
(*@VMS: [global] *)
procedure KbdQuery;
var
c: char;
begin (* KbdQuery *)
if MacroRunning then (* NOOP unless a macro is running *)
begin
MacroRunning := false; (* Stop the macro temporarily *)
EchoClear;
EchoString('Kbd Query ');
WinUpDate;
c := QReadC; (* Wait for the user to type something *)
EchoClear;
while ((c = Chr(HelpChar)) or (c = Chr(CtrlR)) or (c = Chr(CtrlL)))
and not metabit do
begin
if c = Chr(HelpChar)
then begin (* Print help for Keyboard Macro Query *)
OvWString('You are entering an argument to ');
OvWString('a Keyboard Macro Query. '); OvWLine;
OvWString('Enter one of the following: '); OvWLine;
OvWString('Space => Continue '); OvWLine;
OvWString('Escape => Stop the Macro '); OvWLine;
OvWString('Rubout => Skip the rest of the Macro '); OvWLine;
OvWString('C-R => Enter recursive editing '); OvWLine;
OvWString('C-L => Redisplay the screen '); OvWLine;
OvWString('Any other character will stop the Macro ');
OvWString('and be reread again. '); OvWLine;
end else begin
if c = chr(CtrlR) then begin
RecLevel := RecLevel + 1; (* Enter recursive editing *)
CommandLoop('Kbd Query. ');
RecLevel := RecLevel - 1;
EchoClear;
end;
WinUpDate;
end;
EchoString('Kbd Query ');
EchoUpDate;
c := QReadC;
EchoClear;
end;
if metabit then
reread
else
if c = ' ' then (* Space => continue *)
MacroRunning := true
else
if c = Chr(rubout) then (* Rubout => skip the rest *)
begin
MacroRunning := true;
kbdend(0, false)
end
else
if c <> Chr(escape) then (* Escape => Stop the macro *)
reread;
end;
end; (* KbeQuery *)
(*---------------------------------------------------------------------------*)
(* This procedure initializes the INPUT module. *)
(*@VMS: [global] *)
procedure InInit(Total: boolean);
begin
Again := false; (* Turn off character reread flag *)
filing := false; (* Not handling any init file *)
MacroRunning := false;
RecLevel := 0; (* No recursion at initialization time *)
DefiningMacro := false; (* Halt macro definition if reinitialized *)
AutoStarted := false; (* Set lazy echo flags to something sensible *)
AutoCount := 0;
if Total then begin (* First time? *)
new(ZeroMacro); (* Yes, set up macro header *)
ZeroMacro^.Left := ZeroMacro;
ZeroMacro^.Right := ZeroMacro;
ZeroMacro^.Size := 0;
ZeroMacro^.Number := 0;
LastFrozen := 0; (* Start freeze at zero *)
end;
end;
(*---------------------------------------------------------------------------*)
(* ==> SCREEN *)
(*@VMS: [global] *)
procedure EchoClear;
var
x, y: integer;
i: integer;
begin
EchoSize(x, y); (* Get height of echo area *)
for i := 0 to x-1 do
begin
EchoPos(i, 0); (* Position cursor *)
EchoEol; (* Clear line *)
end;
EchoPos(0,0); (* Position at the echo area *)
AutoStarted := false;
AutoCount := 0;
end;
(*---------------------------------------------------------------------------*)
(*@TOPS: begin end. *)
(*@VMS: end. *)