Category : Pascal Source Code
Archive   : SOFTOOLS.ZIP
Filename : CHAPTER8.PAS

{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 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 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 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;