mirror of
https://github.com/PDP-10/stacken.git
synced 2026-04-19 08:29:59 +00:00
642 lines
18 KiB
ObjectPascal
642 lines
18 KiB
ObjectPascal
program MakTrm;
|
|
|
|
label 9;
|
|
|
|
const
|
|
strsize = 40;
|
|
tab = 9;
|
|
rubout = 127;
|
|
nfeatures = 50;
|
|
|
|
type
|
|
string = packed array[1..strsize] of char;
|
|
|
|
fttype = (cursorop,number,yesno,tristate,termname);
|
|
|
|
ft = record
|
|
tag : string;
|
|
size : integer;
|
|
text : string;
|
|
syntax : fttype;
|
|
synonyme : integer;
|
|
end;
|
|
|
|
var
|
|
infile : file of char;
|
|
outfile : file of char;
|
|
c : char;
|
|
more : Boolean;
|
|
tagbuf : string;
|
|
taglength : integer;
|
|
j : integer;
|
|
feature : array[1..nfeatures] of ft;
|
|
newterm : Boolean;
|
|
atombuf : string;
|
|
atomlength : integer;
|
|
newdcaflag : boolean;
|
|
newscrflag : boolean;
|
|
exceptions : boolean;
|
|
|
|
function rdline(var answ: string): integer;
|
|
var i,j: integer; buf: string;
|
|
begin
|
|
i:=0;
|
|
readln(tty, buf:i);
|
|
if buf<>' ' then answ:=buf;
|
|
rdline:=i
|
|
end;
|
|
|
|
procedure warn(msg: string);
|
|
begin
|
|
writeln(tty,msg);
|
|
writeln(tty,' (tag = "', tagbuf:taglength, '")');
|
|
end;
|
|
|
|
procedure error(msg: string);
|
|
begin
|
|
warn(msg);
|
|
goto 9
|
|
end;
|
|
|
|
procedure eat1;
|
|
begin
|
|
if eof(infile) or eoln(infile) then
|
|
more:=false
|
|
else begin
|
|
c:=infile^;
|
|
get(infile);
|
|
more:=true
|
|
end
|
|
end;
|
|
|
|
function upcase(c: char): char;
|
|
begin
|
|
if (97<=ord(c)) and (ord(c)<=122)
|
|
then upcase:=chr(ord(c)-32)
|
|
else upcase:=c
|
|
end;
|
|
|
|
function spaceortab(c: char): Boolean;
|
|
begin
|
|
spaceortab:= (c=' ') or (c=chr(tab))
|
|
end;
|
|
|
|
procedure skipblanks;
|
|
begin
|
|
while more and spaceortab(c) do eat1
|
|
end;
|
|
|
|
function striptail(buf: string; i: integer): integer;
|
|
var j: integer; f: Boolean;
|
|
begin
|
|
j:=i; f:=false;
|
|
repeat
|
|
if j<=0 then f:=true
|
|
else if not spaceortab(buf[j]) then f:=true
|
|
else j:=j-1
|
|
until f;
|
|
striptail:=j
|
|
end;
|
|
|
|
procedure getnewline;
|
|
begin
|
|
while more do eat1;
|
|
if not eof(infile) then begin
|
|
readln(infile);
|
|
more:=true
|
|
end
|
|
end;
|
|
|
|
function uptocolon: Boolean;
|
|
var i: integer;
|
|
begin
|
|
eat1;
|
|
skipblanks;
|
|
while more and (c=';') do begin
|
|
getnewline;
|
|
eat1;
|
|
skipblanks
|
|
end;
|
|
i:=0;
|
|
while more and (c<>':') and (i<strsize) do begin
|
|
i:=i+1;
|
|
tagbuf[i]:=c;
|
|
eat1
|
|
end;
|
|
taglength:=striptail(tagbuf,i);
|
|
uptocolon:=(c=':')
|
|
end;
|
|
|
|
function strcomp(s1,s2: string; s1len: integer; s2end: char): Boolean;
|
|
var f: Boolean; i: integer;
|
|
begin
|
|
i:=1;
|
|
f:=(i<=s1len) and (s2[1]<>s2end);
|
|
while f and (i<=s1len) and (s2[i]<>s2end) do begin
|
|
if s2[i]<>upcase(s1[i]) then f:=false
|
|
else i:=i+1
|
|
end;
|
|
strcomp:=f
|
|
end;
|
|
|
|
function digitp(base: integer; c: char): Boolean;
|
|
begin
|
|
if base<=10 then digitp:=('0'<=c) and (c<chr(ord('0')+base))
|
|
else if base<=16 then
|
|
digitp:=(('0'<=c) and (c<='9')) or
|
|
(('A'<=c) and (c<chr(ord('A')+base-10)))
|
|
end;
|
|
|
|
function getnumber(base: integer): integer;
|
|
var n,d: integer;
|
|
begin
|
|
n:=0;
|
|
c:=upcase(c);
|
|
while more and digitp(base,c) do begin
|
|
d:=ord(c)-ord('0');
|
|
if (base>10) and (d>9) then d:=d-(ord('A')-ord('9')-1);
|
|
n:=base*n+d;
|
|
eat1;
|
|
c:=upcase(c)
|
|
end;
|
|
getnumber:=n
|
|
end;
|
|
|
|
procedure putchar(c: char);
|
|
begin
|
|
outfile^:=c; put(outfile)
|
|
end;
|
|
|
|
procedure putnum1(n, digits: integer);
|
|
begin
|
|
if digits>0 then begin
|
|
putnum1(n div 10, digits-1);
|
|
putchar(chr(ord('0')+(n mod 10)));
|
|
end
|
|
end;
|
|
|
|
procedure putnumber(i, digits: integer);
|
|
begin
|
|
putnum1(feature[i].size, digits)
|
|
end;
|
|
|
|
procedure putbit(b: Boolean);
|
|
begin
|
|
if b then putchar('1') else putchar('0')
|
|
end;
|
|
|
|
procedure puttristate(i: integer);
|
|
begin
|
|
case i of
|
|
0: putchar('F'); (* NO *)
|
|
1: putchar('T'); (* YES *)
|
|
2: putchar('U'); (* UNKNOWN *)
|
|
end;
|
|
end;
|
|
|
|
procedure putcursorop(i: integer);
|
|
var j,n: integer;
|
|
begin
|
|
n:=feature[i].size;
|
|
putnum1(n,2);
|
|
for j:=1 to n do putchar(feature[i].text[j])
|
|
end;
|
|
|
|
function lookuptag: integer;
|
|
var i: integer; f: Boolean;
|
|
begin
|
|
i:=nfeatures; f:=false;
|
|
repeat
|
|
if strcomp(tagbuf,feature[i].tag,taglength,':') then f:=true
|
|
else begin
|
|
i:=i-1;
|
|
if i=0 then f:=true
|
|
end
|
|
until f;
|
|
lookuptag:=i
|
|
end;
|
|
|
|
procedure putterm;
|
|
var i,j: integer;
|
|
begin
|
|
(* write terminal stuff to outfile *)
|
|
for i:=1 to feature[1].size do putchar(feature[1].text[i]);
|
|
for i:=feature[1].size+1 to 6 do putchar(' ');
|
|
putcursorop(2);
|
|
putcursorop(3);
|
|
putcursorop(4);
|
|
putcursorop(5);
|
|
putcursorop(6);
|
|
putcursorop(7);
|
|
putnumber(8,4);
|
|
putcursorop(9);
|
|
putnumber(10,4);
|
|
putnum1(0,2); (* Feature 11. Obsolete. *)
|
|
putnum1(0,2); (* Feature 12. Obsolete. *)
|
|
putcursorop(13);
|
|
putcursorop(14);
|
|
putcursorop(15);
|
|
putnumber(16,4);
|
|
putnum1(0,2); (* Feature 17. Obsolete. *)
|
|
putnum1(0,2); (* Feature 18. Obsolete. *)
|
|
putnumber(19,4);
|
|
putnum1(0,2); (* Feature 20. Obsolete. *)
|
|
putcursorop(21);
|
|
putcursorop(22);
|
|
putcursorop(23);
|
|
putcursorop(24);
|
|
putbit(feature[2].size>0);
|
|
putbit(feature[3].size>0);
|
|
putbit(feature[4].size>0);
|
|
putbit(feature[5].size>0);
|
|
putbit(feature[7].size>0);
|
|
putbit(feature[6].size>0);
|
|
putbit(newdcaflag);
|
|
putbit(feature[27].size>0);
|
|
putbit(feature[9].size>0);
|
|
putbit((feature[13].size>0) and (feature[15].size>0));
|
|
putbit(newscrflag);
|
|
putbit((feature[21].size>0) and (feature[22].size>0));
|
|
putnumber(25,3);
|
|
putnumber(26,2);
|
|
puttristate(feature[28].size);
|
|
putnum1(ord(feature[29].text[1]),3);
|
|
if newdcaflag then begin (* Here we go... *)
|
|
putcursorop(30); (* DCA Lead in string *)
|
|
putcursorop(31); (* DCA Intermediate string *)
|
|
putcursorop(32); (* DCA Trailing string *)
|
|
putbit(feature[33].size>0); (* DCA Coordinates decimal *)
|
|
putbit(feature[34].size>0); (* DCA Column first *)
|
|
putbit(feature[35].size>0); (* DCA Row negate *)
|
|
putbit(feature[36].size>0); (* DCA Column negate *)
|
|
putbit(exceptions); (* '1' if column exceptions. *)
|
|
putbit(feature[42].size>0); (* Use Return to go to left margin. *)
|
|
putnumber(37,3); (* DCA Row offset *)
|
|
putnumber(38,3); (* DCA Column offset *)
|
|
putnumber(39,3); (* DCA Exception begin *)
|
|
putnumber(40,3); (* DCA Exception end *)
|
|
putnumber(41,3); (* DCA Exception offset *)
|
|
putchar('0'); (* Extended version number. *)
|
|
end;
|
|
if newscrflag then begin (* Here we go again... *)
|
|
putbit(feature[43].size>0); (* VT100 Region Scroll *)
|
|
putcursorop(44); (* Insert Line Begin *)
|
|
putcursorop(45); (* Insert Line End *)
|
|
putcursorop(46); (* Delete Line Begin *)
|
|
putcursorop(47); (* Delete Line End *)
|
|
putbit(feature[48].size>0); (* Insert/Delete multiple lines *)
|
|
putbit(feature[49].size>0); (* I/D Line Argument Decimal *)
|
|
putnumber(50,3); (* I/D Line Argument Offset *)
|
|
putchar('0'); (* Dummy, for expansion. *)
|
|
end;
|
|
putchar(chr(13)); putchar(chr(10));
|
|
end;
|
|
|
|
function notdelim(c: char): Boolean;
|
|
begin
|
|
notdelim:=not(spaceortab(c) or (c=';'))
|
|
end;
|
|
|
|
procedure readatom;
|
|
var i: integer;
|
|
begin
|
|
i:=0;
|
|
while more and notdelim(c) and (i<strsize) do begin
|
|
i:=i+1;
|
|
atombuf[i]:=upcase(c);
|
|
eat1
|
|
end;
|
|
atomlength:=i
|
|
end;
|
|
|
|
function atomeq(s: string): Boolean;
|
|
begin
|
|
atomeq:=strcomp(atombuf,s,atomlength,' ')
|
|
end;
|
|
|
|
procedure clearterm;
|
|
var i: integer;
|
|
begin
|
|
for i:=1 to nfeatures do feature[i].size:=0;
|
|
feature[25].size := 80; (* Default terminal width. *)
|
|
feature[26].size := 24; (* Default terminal length. *)
|
|
feature[28].size := 2; (* Wrap behavour unknown *)
|
|
feature[29].size := 1; (* Set default fill char *)
|
|
feature[29].text[1] := chr(rubout);
|
|
feature[42].size := 1; (* Normally CR goes to left margin. *)
|
|
newdcaflag := false; (* We have not seen any dca stuff yet. *)
|
|
newscrflag := false; (* We have not seen any scroll stuff yet. *)
|
|
exceptions := false; (* Nothing exceptional yet. *)
|
|
end;
|
|
|
|
procedure blankorcomment;
|
|
begin
|
|
skipblanks;
|
|
if more then begin
|
|
if not (c=';') then
|
|
warn('%Extra garbage ignored ');
|
|
while more do eat1
|
|
end
|
|
end;
|
|
|
|
procedure parseyesno(index: integer);
|
|
begin
|
|
skipblanks;
|
|
readatom;
|
|
if atomeq('YES ') then
|
|
feature[index].size:=1
|
|
else if atomeq('NO ') then
|
|
feature[index].size:=0
|
|
else warn('%Value must be YES or NO ');
|
|
blankorcomment
|
|
end;
|
|
|
|
procedure parsetristate(index: integer);
|
|
begin
|
|
SkipBlanks;
|
|
ReadAtom;
|
|
with feature[index] do
|
|
if AtomEq('UNKNOWN ') then size := 2
|
|
else if AtomEq('YES ') then size := 1
|
|
else if AtomEq('NO ') then size := 0
|
|
else warn('%Value must be YES, NO or UNKNOWN ');
|
|
BlankOrComment;
|
|
end;
|
|
|
|
procedure parsenumber(index: integer);
|
|
begin
|
|
skipblanks;
|
|
if digitp(10,c) then
|
|
feature[index].size:=getnumber(10)
|
|
else if c='%' then begin
|
|
eat1;
|
|
feature[index].size:=getnumber(8)
|
|
end
|
|
else if c='#' then begin
|
|
eat1;
|
|
feature[index].size:=getnumber(16)
|
|
end
|
|
else warn('%Illegal syntax for number ');
|
|
blankorcomment
|
|
end;
|
|
|
|
procedure parsecursorop(index: integer);
|
|
var i: integer;
|
|
begin
|
|
with feature[index] do begin
|
|
i:=0;
|
|
repeat
|
|
skipblanks;
|
|
if digitp(10,c) then begin
|
|
i:=i+1;
|
|
text[i]:=chr(getnumber(10))
|
|
end
|
|
else if c='%' then begin
|
|
i:=i+1;
|
|
eat1;
|
|
text[i]:=chr(getnumber(8))
|
|
end
|
|
else if c='#' then begin
|
|
i:=i+1;
|
|
eat1;
|
|
text[i]:=chr(getnumber(16))
|
|
end
|
|
else if c='^' then begin
|
|
i:=i+1;
|
|
eat1;
|
|
c:=upcase(c);
|
|
if (ord(c)<64) or (ord(c)>=96) then
|
|
warn('%Illegal character following "^" ')
|
|
else
|
|
text[i]:=chr(ord(upcase(c))-64);
|
|
eat1
|
|
end
|
|
else if c='"' then begin
|
|
eat1;
|
|
while more and (c<>'"') do begin
|
|
i:=i+1;
|
|
text[i]:=c;
|
|
eat1
|
|
end;
|
|
if not more then warn('%Missing string quote ')
|
|
else eat1
|
|
end
|
|
else if c='-' then begin
|
|
eat1;
|
|
blankorcomment;
|
|
getnewline;
|
|
eat1
|
|
end
|
|
else begin
|
|
readatom;
|
|
if atomeq('NULL ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(0)
|
|
end
|
|
else if atomeq('BELL ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(7)
|
|
end
|
|
else if atomeq('BACKSPACE ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(8)
|
|
end
|
|
else if atomeq('TAB ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(9)
|
|
end
|
|
else if atomeq('LINEFEED ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(10)
|
|
end
|
|
else if atomeq('FORMFEED ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(12)
|
|
end
|
|
else if atomeq('RETURN ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(13)
|
|
end
|
|
else if atomeq('ESCAPE ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(27)
|
|
end
|
|
else if atomeq('SPACE ')
|
|
or atomeq('BLANK ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(32)
|
|
end
|
|
else if atomeq('RUBOUT ')
|
|
or atomeq('DELETE ') then begin
|
|
i:=i+1;
|
|
text[i]:=chr(127)
|
|
end
|
|
else blankorcomment
|
|
end
|
|
until not more;
|
|
size:=i
|
|
end
|
|
end;
|
|
|
|
procedure parsetermname(index: integer);
|
|
begin
|
|
if newterm then putterm;
|
|
newterm:=true;
|
|
clearterm;
|
|
parsecursorop(index);
|
|
writeln(tty,'Processing ', feature[index].text:feature[index].size);
|
|
end;
|
|
|
|
procedure parse;
|
|
var
|
|
index: integer;
|
|
colonfound: Boolean;
|
|
syntax: fttype;
|
|
begin
|
|
colonfound:=uptocolon;
|
|
index:=lookuptag;
|
|
if (not colonfound) and (index>0) then begin
|
|
warn('%Tag must end with colon ');
|
|
colonfound:=true
|
|
end;
|
|
if (not colonfound) and (taglength>0) then
|
|
warn('%Can''t parse garbage ')
|
|
else if index=0 then begin
|
|
if taglength>0 then
|
|
warn('%Tag not found ')
|
|
end
|
|
else begin
|
|
eat1;
|
|
syntax:=feature[index].syntax;
|
|
index:=feature[index].synonyme;
|
|
if (index >= 30) and (index <= 41) then newdcaflag := true;
|
|
if (index >= 39) and (index <= 41) then exceptions := true;
|
|
if (index >= 43) and (index <= 50) then newscrflag := true;
|
|
if (not newterm) and (syntax<>termname)
|
|
then error('?Entry must begin with terminal name ')
|
|
else case syntax of
|
|
termname: parsetermname(index);
|
|
cursorop: parsecursorop(index);
|
|
number: parsenumber(index);
|
|
yesno: parseyesno(index);
|
|
tristate: parsetristate(index);
|
|
end;
|
|
end;
|
|
getnewline;
|
|
end;
|
|
|
|
procedure initerm;
|
|
var i: integer;
|
|
begin
|
|
for i:=1 to nfeatures do begin
|
|
feature[i].syntax:=cursorop;
|
|
feature[i].synonyme:=i;
|
|
end;
|
|
clearterm;
|
|
feature[1].tag:='TERMINAL NAME: ';
|
|
feature[1].syntax:=termname;
|
|
feature[2].tag:='CURSOR UP: ';
|
|
feature[3].tag:='CURSOR DOWN: ';
|
|
feature[4].tag:='CURSOR LEFT: ';
|
|
feature[5].tag:='CURSOR RIGHT: ';
|
|
feature[6].tag:='CURSOR HOME: ';
|
|
feature[7].tag:='ERASE FROM CURSOR TO END OF LINE: ';
|
|
feature[8].tag:='TIME NEEDED FOR ERASING TO END OF LINE: ';
|
|
feature[8].syntax:=number;
|
|
feature[9].tag:='CLEAR SCREEN: ';
|
|
feature[10].tag:='TIME NEEDED TO CLEAR SCREEN: ';
|
|
feature[10].syntax:=number;
|
|
(***** The following two are obsoleted *****)
|
|
feature[11].tag:=' DIRECT CURSOR ADDRESSING CHARACTERS:';
|
|
feature[12].tag:=' DIRECT CURSOR ADDRESSING ALGORITHM:';
|
|
feature[12].syntax:=number;
|
|
(***** End of obsoleted features *****)
|
|
feature[13].tag:='INSERT CHARACTER MODE ON: ';
|
|
feature[14].tag:='INSERT CHARACTER MODE OFF: ';
|
|
feature[15].tag:='DELETE CHARACTER: ';
|
|
feature[16].tag:='TIME NEEDED TO INSERT/DELETE CHARACTER: ';
|
|
feature[16].syntax:=number;
|
|
(***** The following two are obsoleted *****)
|
|
feature[17].tag:=' INSERT LINE:';
|
|
feature[18].tag:=' DELETE LINE:';
|
|
(***** End of obsoleted features *****)
|
|
feature[19].tag:='TIME NEEDED TO INSERT/DELETE LINE: ';
|
|
feature[19].syntax:=number;
|
|
(***** The following is obsoleted *****)
|
|
feature[20].tag:=' REGION SCROLL ALGORITHM:';
|
|
feature[20].syntax:=number;
|
|
(***** End of obsoleted feature *****)
|
|
feature[21].tag:='HIGHLIGHT MODE ON: ';
|
|
feature[22].tag:='HIGHLIGHT MODE OFF: ';
|
|
feature[23].tag:='TERMINAL INITIALIZATION STRING: ';
|
|
feature[24].tag:='TERMINAL DEACTIVATION STRING: ';
|
|
feature[25].tag:='TERMINAL WIDTH: ';
|
|
feature[25].syntax:=number;
|
|
feature[26].tag:='TERMINAL PAGE LENGTH: ';
|
|
feature[26].syntax:=number;
|
|
feature[27].tag:='FIXED TAB STOPS EVERY 8 COLUMNS: ';
|
|
feature[27].syntax:=yesno;
|
|
feature[28].tag:='WRAP AROUND FROM LAST COLUMN: ';
|
|
feature[28].syntax:=tristate;
|
|
feature[29].tag:='FILL CHARACTER: ';
|
|
|
|
(* --- New DCA handling --- *)
|
|
|
|
feature[30].tag := 'DCA LEAD IN STRING: ';
|
|
feature[31].tag := 'DCA INTERMEDIATE STRING: ';
|
|
feature[32].tag := 'DCA TRAILING STRING: ';
|
|
feature[33].tag := 'DCA COORDINATES DECIMAL: ';
|
|
feature[33].syntax := yesno;
|
|
feature[34].tag := 'DCA COLUMN FIRST: ';
|
|
feature[34].syntax := yesno;
|
|
feature[35].tag := 'DCA ROW NEGATE: ';
|
|
feature[35].syntax := yesno;
|
|
feature[36].tag := 'DCA COLUMN NEGATE: ';
|
|
feature[36].syntax := yesno;
|
|
feature[37].tag := 'DCA ROW OFFSET: ';
|
|
feature[37].syntax := number;
|
|
feature[38].tag := 'DCA COLUMN OFFSET: ';
|
|
feature[38].syntax := number;
|
|
feature[39].tag := 'DCA EXCEPTION BEGIN: ';
|
|
feature[39].syntax := number;
|
|
feature[40].tag := 'DCA EXCEPTION END: ';
|
|
feature[40].syntax := number;
|
|
feature[41].tag := 'DCA EXCEPTION OFFSET: ';
|
|
feature[41].syntax := number;
|
|
feature[42].tag := 'CR GOES TO LEFT MARGIN: ';
|
|
feature[42].syntax := yesno;
|
|
|
|
(* --- New region scroll handling --- *)
|
|
|
|
feature[43].tag := 'VT100 REGION SCROLL: ';
|
|
feature[43].syntax := yesno;
|
|
feature[44].tag := 'INSERT LINE: ';
|
|
feature[45].tag := 'TERMINATE INSERT LINE: ';
|
|
feature[46].tag := 'DELETE LINE: ';
|
|
feature[47].tag := 'TERMINATE DELETE LINE: ';
|
|
feature[48].tag := 'I/D MULTIPLE LINES: ';
|
|
feature[48].syntax := yesno;
|
|
feature[49].tag := 'I/D LINE ARGUMENT DECIMAL: ';
|
|
feature[49].syntax := yesno;
|
|
feature[50].tag := 'I/D LINE ARGUMENT OFFSET: ';
|
|
feature[50].syntax := number;
|
|
end;
|
|
|
|
begin
|
|
write(tty, 'Input file /AMIS.DEC/ : ');
|
|
atombuf:='AMIS.DEC ';
|
|
atomlength:=rdline(atombuf);
|
|
reset(infile,atombuf);
|
|
write(tty, 'Output file /AMIS.TRM/ : ');
|
|
atombuf:='AMIS.TRM ';
|
|
atomlength:=rdline(atombuf);
|
|
rewrite(outfile,atombuf);
|
|
initerm;
|
|
more:=true;
|
|
newterm:=false;
|
|
while more do parse;
|
|
if newterm then putterm
|
|
else error('?Unexpected end of file ');
|
|
9:
|
|
end.
|