home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
ENTERPRS
/
CPM
/
UTILS
/
S
/
TURBTOOL.ARC
/
CHAPTER8.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-09-27
|
13KB
|
605 lines
{chapter8.pas}
{
copyright (c) 1981
by: bell telephone laboratories, inc. and
whitesmith's ltd.,
this software is derived from the book
"software tools in pascal", by
brian w. kernighan and p. j. plauger
addison-wesley, 1981
isbn 0-201-10342-7
right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
procedure macro;
const
bufsize=1000;
maxchars=500;
maxpos=500;
callsize=maxpos;
argsize=maxpos;
evalsize=maxchars;
maxdef=maxstr;
maxtok=maxstr;
hashsize=53;
argflag=dollar;
type
charpos=1..maxchars;
charbuf=array[1..maxchars]of character;
posbuf=array[1..maxpos]of charpos;
pos=0..maxpos;
sttype=(deftype,mactype,iftype,subtype,
exprtype,lentype,chqtype);
ndptr=^ndblock;
ndblock=record
name:charpos;
defn:charpos;
kind:sttype;
nextptr:ndptr
end;
var
buf:array[1..bufsize]of character;
bp:0..bufsize;
hashtab:array[1..hashsize]of ndptr;
ndtable:charbuf;
nexttab:charpos;
callstk:posbuf;
cp:pos;
typestk:array[1..callsize]of sttype;
plev:array[1..callsize]of integer;
argstk:posbuf;
ap:pos;
evalstk:charbuf;
ep:charpos;
(*builtins*)
defname:xstring;
exprname:xstring;
subname,ifname,lenname,chqname:xstring;
null:xstring;
lquote,rquote:character;
defn,token:xstring;
toktype:sttype;
t:character;
nlpar:integer;
procedure putchr(c:character);
begin
if(cp<=0) then
putc(c)
else begin
if(ep>evalsize)then
error('macro:evaluation stack overflow');
evalstk[ep]:=c;
ep:=ep+1
end
end;
procedure puttok(var s:xstring);
var
i:integer;
begin
i:=1;
while(s[i]<>endstr) do begin
putchr(s[i]);
i:=i+1
end
end;
function push(ep:integer;var argstk:posbuf;ap:integer):integer;
begin
if(ap>argsize)then
error('macro:argument stack overflow');
argstk[ap]:=ep;
push:=ap+1
end;
procedure sccopy(var s:xstring;var cb:charbuf;
i:charpos);
var j:integer;
begin
j:=1;
while(s[j]<>endstr)do begin
cb[i]:=s[j];
j:=j+1;
i:=i+1
end;
cb[i]:=endstr
end;
procedure cscopy(var cb:charbuf;i:charpos;
var s:xstring);
var j:integer;
begin
j:=1;
while(cb[i]<>endstr)do begin
s[j]:=cb[i];
i:=i+1;
j:=j+1
end;
s[j]:=endstr
end;
procedure putback(c:character);
begin
if(bp>=bufsize)then
writeln('too many characters pushed back');
bp:=bp+1;
buf[bp]:=c
end;
function getpbc(var c:character):character;
begin
if(bp>0)then
c:=buf[bp]
else begin
bp:=1;
buf[bp]:=getc(c)
end;
if(c<>endfile)then
bp:=bp-1;
getpbc:=c
end;
function gettok(var token:xstring;toksize:integer):
character;
var i:integer;
done:boolean;
begin
i:=1;
done:=false;
while(not done) and (i<toksize) do
if(isalphanum(getpbc(token[i]))) then
i:=i+1
else
done:=true;
if(i>=toksize)then
writeln('define:token too long');
if(i>1) then begin (*some alpha was seen*)
putback(token[i]);
i:=i-1
end;
(*else single non-alphanumeric*)
token[i+1]:=endstr;
gettok:=token[1]
end;
procedure pbstr (var s:xstring);
var i:integer;
begin
for i:=xlength(s) downto 1 do
putback(s[i])
end;
function hash(var name:xstring):integer;
var
i,h:integer;
begin
h:=0;
for i:=1 to xlength(name) do
h:=(3*h+name[i]) mod hashsize;
hash:=h+1
end;
function hashfind(var name:xstring):ndptr;
var
p:ndptr;
tempname:xstring;
found:boolean;
begin
found:=false;
p:=hashtab[hash(name)];
while (not found) and (p<>nil) do begin
cscopy(ndtable,p^.name,tempname);
if(equal(name,tempname)) then
found:=true
else
p:=p^.nextptr
end;
hashfind:=p
end;
procedure inithash;
var i:1..hashsize;
begin
nexttab:=1;
for i:=1 to hashsize do
hashtab[i]:=nil
end;
function lookup(var name,defn:xstring; var t:sttype)
:boolean;
var p:ndptr;
begin
p:=hashfind(name);
if(p=nil)then
lookup:=false
else begin
lookup:=true;
cscopy(ndtable,p^.defn,defn);
t:=p^.kind
end
end;
procedure install(var name,defn:xstring;t:sttype);
var
h,dlen,nlen:integer;
p:ndptr;
begin
nlen:=xlength(name)+1;
dlen:=xlength(defn)+1;
if(nexttab + nlen +dlen > maxchars) then begin
putstr(name,stderr);
error(':too many definitions')
end
else begin
h:=hash(name);
new(p);
p^.nextptr:=hashtab[h];
hashtab[h]:=p;
p^.name:=nexttab;
sccopy(name,ndtable,nexttab);
nexttab:=nexttab+nlen;
p^.defn:=nexttab;
sccopy(defn,ndtable,nexttab);
nexttab:=nexttab+dlen;
p^.kind:=t
end
end;
procedure dodef(var argstk:posbuf;i,j:integer);
var
temp1,temp2 : xstring;
begin
if(j-i>2) then begin
cscopy(evalstk,argstk[i+2],temp1);
cscopy(evalstk,argstk[i+3],temp2);
install(temp1,temp2,mactype)
end
end;
procedure doif(var argstk:posbuf;i,j:integer);
var
temp1,temp2,temp3:xstring;
begin
if(j-i>=4) then begin
cscopy(evalstk,argstk[i+2],temp1);
cscopy(evalstk,argstk[i+3],temp2);
if(equal(temp1,temp2))then
cscopy(evalstk,argstk[i+4],temp3)
else if (j-i>=5) then
cscopy(evalstk,argstk[i+5],temp3)
else
temp3[i]:=endstr;
pbstr(temp3)
end
end;
procedure pbnum(n:integer);
var
temp:xstring;
junk:integer;
begin
junk:=itoc(n,temp,1);
pbstr(temp)
end;
function expr(var s:xstring;var i:integer):integer;forward;
procedure doexpr(var argstk:posbuf;i,j:integer);
var
junk:integer;
temp:xstring;
begin
cscopy(evalstk,argstk[i+2],temp);
junk:=1;
pbnum(expr(temp,junk))
end;
function expr;
var
v:integer;
t:character;
function gnbchar(var s:xstring;var i:integer):character;
begin
while(s[i]in[blank,tab,newline])do
i:=i+1;
gnbchar:=s[i]
end;
function term(var s:xstring;var i:integer):integer;
var
v:integer;
t:character;
function factor (var s:xstring;var i:integer):
integer;
begin
if(gnbchar(s,i)=lparen) then begin
i:=i+1;
factor:=expr(s,i);
if(gnbchar(s,i)=rparen) then
i:=i+1
else
writeln('macro:missing paren in expr')
end
else
factor:=ctoi(s,i)
end;(*factor*)
begin(*term*)
v:=factor(s,i);
t:=gnbchar(s,i);
while(t in [star,slash,percent]) do begin
i:=i+1;
case t of
star:v:=v*factor(s,i);
slash:
v:=v div factor(s,i);
percent:
v:=v mod factor(s,i)
end;
t:=gnbchar(s,i)
end;
term:=v
end;(*term*)
begin(*expr*)
v:=term(s,i);
t:=gnbchar(s,i);
while(t in [plus,minus])do begin
i:=i+1;
if(t in [plus]) then
v:=v+term(s,i)
else(*minus*)
v:=v-term(s,i);
t:=gnbchar(s,i)
end;
expr:=v
end;
procedure dolen(var argstk:posbuf;i,j:integer);
var
temp:xstring;
begin
if(j-i>1)then begin
cscopy(evalstk,argstk[i+2],temp);
pbnum(xlength(temp))
end
else
pbnum(0)
end;
procedure dosub(var argstk:posbuf;i,j:integer);
var
ap,fc,k,nc:integer;
temp1,temp2:xstring;
begin
if(j-i>=3) then begin
if(j-i<4) then
nc:=maxtok
else begin
cscopy(evalstk,argstk[i+4],temp1);
k:=1;
nc:=expr(temp1,k)
end;
cscopy(evalstk,argstk[i+3],temp1);
ap:=argstk[i+2];
k:=1;
fc:=ap+expr(temp1,k)-1;
cscopy(evalstk,ap,temp2);
if(fc>=ap) and (fc<ap+xlength(temp2)) then begin
cscopy(evalstk,fc,temp1);
for k:=fc+min(nc,xlength(temp1))-1 downto fc do
putback(evalstk[k])
end
end
end;
procedure dochq(var argstk:posbuf;i,j:integer);
var
temp:xstring;
n:integer;
begin
cscopy(evalstk,argstk[i+2],temp);
n:=xlength(temp);
if(n<=0)then begin
lquote:=ord(less);
rquote:=ord(greater)
end
else if (n=1) then begin
lquote:=temp[1];
rquote:=lquote
end
else begin
lquote:=temp[1];
rquote:=temp[2]
end
end;
procedure eval(var argstk:posbuf;td:sttype;
i,j:integer);
var
argno,k,t:integer;
temp:xstring;
begin
t:=argstk[i];
if(td=deftype)then
dodef(argstk,i,j)
else if (td=exprtype)then
doexpr(argstk,i,j)
else if (td=subtype) then
dosub(argstk,i,j)
else if (td=iftype) then
doif(argstk,i,j)
else if (td=lentype) then
dolen(argstk,i,j)
else if (td=chqtype) then
dochq(argstk,i,j)
else begin
k:=t;
while(evalstk[k]<>endstr) do
k:=k+1;
k:=k-1;
while(k>t) do begin
if(evalstk[k-1] <> argflag) then
putback(evalstk[k])
else begin
argno:=ord(evalstk[k])-ord('0');
if(argno>=0) and (argno <j-i)then begin
cscopy(evalstk,argstk[i+argno+1],temp);
pbstr(temp)
end;
k:=k-1
end;
k:=k-1
end;
if(k=t)then
putback(evalstk[k])
end
end;
procedure initmacro;
begin
null[1]:=endstr;
defname[1]:=ord('d');
defname[2]:=ord('e');
defname[3]:=ord('f');
defname[4]:=ord('i');
defname[5]:=ord('n');
defname[6]:=ord('e');
defname[7]:=endstr;
subname[1]:=ord('s');
subname[2]:=ord('u');
subname[3]:=ord('b');
subname[4]:=ord('s');
subname[5]:=ord('t');
subname[6]:=ord('r');
subname[7]:=endstr;
exprname[1]:=ord('e');
exprname[2]:=ord('x');
exprname[3]:=ord('p');
exprname[4]:=ord('r');
exprname[5]:=endstr;
ifname[1]:=ord('i');
ifname[2]:=ord('f');
ifname[3]:=ord('e');
ifname[4]:=ord('l');
ifname[5]:=ord('s');
ifname[6]:=ord('e');
ifname[7]:=endstr;
lenname[1]:=ord('l');
lenname[2]:=ord('e');
lenname[3]:=ord('n');
lenname[4]:=endstr;
chqname[1]:=ord('c');
chqname[2]:=ord('h');
chqname[3]:=ord('a');
chqname[4]:=ord('n');
chqname[5]:=ord('g');
chqname[6]:=ord('e');
chqname[7]:=ord('q');
chqname[8]:=endstr;
bp:=0;
inithash;
lquote:=ord('`');
rquote:=ord('''')
end;
begin
initmacro;
install(defname,null,deftype);
install(exprname,null,exprtype);
install(subname,null,subtype);
install(ifname,null,iftype);
install(lenname,null,lentype);
install(chqname,null,chqtype);
cp:=0;ap:=1;ep:=1;
while(gettok(token,maxtok)<>endfile)do
if(isletter(token[1]))then begin
if(not lookup(token,defn,toktype))then
puttok(token)
else begin
cp:=cp+1;
if(cp>callsize)then
error('macro:call stack overflow');
callstk[cp]:=ap;
typestk[cp]:=toktype;
ap:=push(ep,argstk,ap);
puttok(defn);
putchr(endstr);
ap:=push(ep,argstk,ap);
puttok(token);
putchr(endstr);
ap:=push(ep,argstk,ap);
t:=gettok(token,maxtok);
pbstr(token);
if(t<>lparen)then begin
putback(rparen);
putback(lparen)
end;
plev[cp]:=0
end
end
else if(token[1]=lquote) then begin
nlpar:=1;
repeat
t:=gettok(token,maxtok);
if(t=rquote)then
nlpar:=nlpar-1
else if (t=lquote)then
nlpar:=nlpar+1
else if (t=endfile) then
error('macro:missing right quote');
if(nlpar>0) then
puttok(token)
until(nlpar=0)
end
else if (cp=0)then
puttok(token)
else if (token[1]=lparen) then begin
if(plev[cp]>0)then
puttok(token);
plev[cp]:=plev[cp]+1
end
else if (token[1]=rparen)then begin
plev[cp]:=plev[cp]-1;
if(plev[cp]>0)then
puttok(token)
else begin
putchr(endstr);
eval(argstk,typestk[cp],callstk[cp],ap-1);
ap:=callstk[cp];
ep:=argstk[ap];
cp:=cp-1
end
end
else if (token[1]=comma) and (plev[cp]=1)then begin
putchr(endstr);
ap:=push(ep,argstk,ap)
end
else
puttok(token);
if(cp<>0)then
error('macro:unexpected end of input')
end;