Software Tools in Pascal for Turbo Pascal (part 3/3)
Tom Reingold
reintom at rocky2.UUCP
Fri Sep 19 15:15:47 AEST 1986
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# chapter8.pas
# fprims.pas
# initcmd.pas
# shell.pas
# toolu.pas
# This archive created: Thu Sep 18 14:28:01 1986
export PATH; PATH=/bin:$PATH
if test -f 'chapter8.pas'
then
echo shar: will not over-write existing file "'chapter8.pas'"
else
cat << \SHAR_EOF > '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<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;
SHAR_EOF
if test 12030 -ne "`wc -c < 'chapter8.pas'`"
then
echo shar: error transmitting "'chapter8.pas'" '(should have been 12030 characters)'
fi
fi # end of overwriting check
if test -f 'fprims.pas'
then
echo shar: will not over-write existing file "'fprims.pas'"
else
cat << \SHAR_EOF > 'fprims.pas'
{fprims.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.
}
CONST
MAXPAT=MAXSTR;
CLOSIZE=1;
CLOSURE=STAR;
BOL=PERCENT;
EOL=DOLLAR;
ANY=QUESTION;
CCL=LBRACK;
CCLEND=RBRACK;
NEGATE=CARET;
NCCL=EXCLAM;
LITCHAR=67;
FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;FORWARD;
FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
VAR PAT:XSTRING; J:INTEGER):INTEGER;FORWARD;
FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;FORWARD;
FUNCTION MAKEPAT;
VAR
I,J,LASTJ,LJ:INTEGER;
DONE,JUNK:BOOLEAN;
FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
VAR
JSTART:INTEGER;
JUNK:BOOLEAN;
PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
VAR I:INTEGER; VAR DEST:XSTRING;
VAR J:INTEGER; MAXSET:INTEGER);
CONST ESCAPE=ATSIGN;
VAR K:INTEGER;
JUNK:BOOLEAN;
FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
IF(S[I]<>ESCAPE) THEN
ESC:=S[I]
ELSE IF (S[I+1]=ENDSTR) THEN
ESC:=ESCAPE
ELSE BEGIN
I:=I+1;
IF (S[I]=ORD('N')) THEN
ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
BEGIN
WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
IF(SRC[I]=ESCAPE)THEN
JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
ELSE IF (SRC[I]<>DASH) THEN
JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
ELSE IF (ISALPHANUM(SRC[I-1]))
AND (ISALPHANUM(SRC[I+1]))
AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
JUNK:=ADDSTR(K,DEST,J,MAXSET);
I:=I+1
END
ELSE
JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
I:=I+1
END
END;
BEGIN
I:=I+1;
IF(ARG[I]=NEGATE) THEN BEGIN
JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
I:=I+1
END
ELSE
JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
JSTART:=J;
JUNK:=ADDSTR(0,PAT,J,MAXPAT);
DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
PAT[JSTART]:=J-JSTART-1;
GETCCL:=(ARG[I]=CCLEND)
END;
PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
LASTJ:INTEGER);
VAR
JP,JT:INTEGER;
JUNK:BOOLEAN;
BEGIN
FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
JT:=JP+CLOSIZE;
JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
END;
J:=J+CLOSIZE;
PAT[LASTJ]:=CLOSURE
END;
BEGIN
J:=1;
I:=START;
LASTJ:=1;
DONE:=FALSE;
WHILE(NOT DONE) AND (ARG[I]<>DELIM)
AND (ARG[I]<>ENDSTR) DO BEGIN
LJ:=J;
IF(ARG[I]=ANY) THEN
JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
ELSE IF (ARG[I]=BOL) AND (I=START) THEN
JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=CCL) THEN
DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
LJ:=LASTJ;
IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
DONE:=TRUE
ELSE
STCLOSE(PAT,J,LASTJ)
END
ELSE BEGIN
JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
END;
LASTJ:=LJ;
IF(NOT DONE) THEN
I:=I+1
END;
IF(DONE) OR (ARG[I]<>DELIM) THEN
MAKEPAT:=0
ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
MAKEPAT:=0
ELSE
MAKEPAT:=I
END;
FUNCTION AMATCH;
VAR I,K:INTEGER;
DONE:BOOLEAN;
FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
VAR
ADVANCE:-1..1;
FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
OFFSET:INTEGER):BOOLEAN;
VAR
I:INTEGER;
BEGIN
LOCATE:=FALSE;
I:=OFFSET+PAT[OFFSET];
WHILE(I>OFFSET) DO
IF(C=PAT[I]) THEN BEGIN
LOCATE :=TRUE;
I:=OFFSET
END
ELSE
I:=I-1
END;BEGIN
ADVANCE:=-1;
IF(LIN[I]=ENDSTR) THEN
OMATCH:=FALSE
ELSE IF (NOT( PAT[J] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN OMATCH:CAN''T HAPPEN')
ELSE
CASE PAT[J] OF
LITCHAR:
IF (LIN[I]=PAT[J+1]) THEN
ADVANCE:=1;
BOL:
IF (I=1) THEN
ADVANCE:=0;
ANY:
IF (LIN[I]<>NEWLINE) THEN
ADVANCE:=1;
EOL:
IF(LIN[I]=NEWLINE) THEN
ADVANCE:=0;
CCL:
IF(LOCATE(LIN[I],PAT,J+1)) THEN
ADVANCE:=1;
NCCL:
IF(LIN[I]<>NEWLINE)
AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
ADVANCE:=1
END;
IF(ADVANCE>=0) THEN BEGIN
I:=I+ADVANCE;
OMATCH:=TRUE
END
ELSE
OMATCH:=FALSE
END;
FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
BEGIN
IF(NOT (PAT[N] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN PATSIZE:CAN''T HAPPEN')
ELSE
CASE PAT[N] OF
LITCHAR:PATSIZE:=2;
BOL,EOL,ANY:PATSIZE:=1;
CCL,NCCL:PATSIZE:=PAT[N+1]+2;
CLOSURE:PATSIZE:=CLOSIZE
END
END;
BEGIN
DONE:=FALSE;
WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
IF(PAT[J]=CLOSURE) THEN BEGIN
J:=J+PATSIZE(PAT,J);
I:=OFFSET;
WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
IF (NOT OMATCH(LIN,I,PAT,J)) THEN
DONE:=TRUE;
DONE:=FALSE;
WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
IF(K>0) THEN
DONE:=TRUE
ELSE
I:=I-1
END;
OFFSET:=K;
DONE:=TRUE
END
ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
THEN BEGIN
OFFSET :=0;
DONE:=TRUE
END
ELSE
J:=J+PATSIZE(PAT,J);
AMATCH:=OFFSET
END;
FUNCTION MATCH;
VAR
I,POS:INTEGER;
BEGIN
POS:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
POS:=AMATCH(LIN,I,PAT,1);
I:=I+1
END;
MATCH:=(POS>0)
END;
SHAR_EOF
if test 6206 -ne "`wc -c < 'fprims.pas'`"
then
echo shar: error transmitting "'fprims.pas'" '(should have been 6206 characters)'
fi
fi # end of overwriting check
if test -f 'initcmd.pas'
then
echo shar: will not over-write existing file "'initcmd.pas'"
else
cat << \SHAR_EOF > 'initcmd.pas'
{initcmd.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 INITCMD;
VAR
FD:FILEDESC;
FNAME:XSTRING;
FT:FILTYP;
IDX:1..MAXSTR;
I,JSKIP:INTEGER;
JUNK:BOOLEAN;
BEGIN
CMDFIL[STDIN]:=STDIO;
CMDFIL[STDOUT]:=STDIO;
CMDFIL[STDERR]:=STDIO;
FOR FD:=SUCC(STDERR) TO MAXOPEN DO
CMDFIL[FD]:=CLOSED;
WRITELN;
write('$ ');
FOR FT:= FIL1 TO FIL4 DO
CMDOPEN[FT]:=FALSE;
KBDN:=0;
if (not getline(cmdlin,STDIN,MAXSTR)) then error('NO CMDLINE');
CMDARGS:=0;
JSKIP:=0;
IDX:=1;
WHILE ((CMDLIN[IDX]<>ENDSTR)
AND(CMDLIN[IDX]<>NEWLINE)) DO BEGIN
WHILE((CMDLIN[IDX]=BLANK)AND(JSKIP MOD 2 <>1))DO
IDX:=IDX+1;
IF(CMDLIN[IDX]<>NEWLINE) THEN BEGIN
CMDARGS:=CMDARGS+1;
CMDIDX[CMDARGS]:=IDX-JSKIP;
WHILE((CMDLIN[IDX]<>NEWLINE)AND
((CMDLIN[IDX]<>BLANK)OR(JSKIP MOD 2 <>0)))DO BEGIN
IF (CMDLIN[IDX]=DQUOTE)THEN BEGIN
JSKIP:=JSKIP+1;
IDX:=IDX+1
END
ELSE BEGIN
CMDLIN[IDX-JSKIP]:=CMDLIN[IDX];
IDX:=IDX+1
END
END;
CMDLIN[IDX-JSKIP]:=ENDSTR;
IDX:=IDX+1;
IF (CMDLIN[CMDIDX[CMDARGS]]=LESS) THEN BEGIN
XCLOSE(STDIN);
CMDIDX[CMDARGS]:=CMDIDX[CMDARGS]+1;
JUNK:=GETARG(CMDARGS,FNAME,MAXSTR);
FD:=MUSTOPEN(FNAME,IOREAD);
CMDARGS:=CMDARGS-1;
END
ELSE IF (CMDLIN[CMDIDX[CMDARGS]]=GREATER) THEN BEGIN
XCLOSE(STDOUT);
CMDIDX[CMDARGS]:=CMDIDX[CMDARGS]+1;
JUNK:=GETARG(CMDARGS,FNAME,MAXSTR);
FD:=MUSTCREATE(FNAME,IOWRITE);
CMDARGS:=CMDARGS-1;
END
END
END;
END;
SHAR_EOF
if test 2249 -ne "`wc -c < 'initcmd.pas'`"
then
echo shar: error transmitting "'initcmd.pas'" '(should have been 2249 characters)'
fi
fi # end of overwriting check
if test -f 'shell.pas'
then
echo shar: will not over-write existing file "'shell.pas'"
else
cat << \SHAR_EOF > 'shell.pas'
{SHELL.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.
}
PROGRAM TOOLS;
{$I TOOLU.PAS}
{$I INITCMD.PAS}
{$I CHAPTER1.PAS}
{$I CHAPTER2.PAS}
{$I CHAPTER3.PAS}
{$I CHAPTER4.PAS}
{$I CHAPTER5.PAS}
{$I CHAPTER6.PAS}
{$I CHAPTER7.PAS}
{$I CHAPTER8.PAS}
VAR
STR,STR1:STRING80;
COMMAND:XSTRING;
DONE:BOOLEAN;
I:INTEGER;
BEGIN {SHELL}
DONE:=FALSE;
WHILE NOT DONE
DO
BEGIN
INITCMD;
IF GETARG(1,COMMAND,MAXSTR)
THEN
BEGIN
STR:='';
STR1:='X';
FOR I:=1 TO XLENGTH(COMMAND)
DO
BEGIN
if COMMAND[I]in[97..122]
then
str1[1]:=chr(command[i]-32)
ELSE STR1[1]:=chr(COMMAND[I]);
STR:=CONCAT(STR,STR1)
END;
if str = 'COPY' then copy
else if str = 'LINECOUNT' then linecount
else if str = 'WORDCOUNT' then wordcount
else if str = 'DETAB' then detab
else if str = 'ENTAB' then entab
else if str = 'OVERSTRIKE' then overstrike
else if str = 'COMPRESS' then compress
else if str = 'EXPAND' then expand
else if str = 'ECHO' then echo
else if str = 'TRANSLIT' then translit
else if str = 'COMPARE' then compare
else if str = 'INCLUDE' then include
else if str = 'CONCAT' then concat
else if str = 'PRINT' then print
else if str = 'MAKECOPY' then makecopy
else if str = 'ARCHIVE' then archive
else if str = 'SORT' then sort
else if str = 'UNIQUE' then unique
else if str = 'KWIC' then kwic
else if str = 'ROTATE' then writeln('ROTATE not directly supported.')
else if str = 'UNROTATE' then unrotate
else if str = 'FIND' then find
else if str = 'CHANGE' then change
else if str = 'EDIT' then edit
else if str = 'FORMAT' then format
else if str = 'DEFINE' then macro
else if str = 'MACRO' then macro
else if str = 'QUIT' then halt
ELSE
BEGIN
WRITELN('?');
DONE:=FALSE
END
END;
endcmd;
END;
END.
SHAR_EOF
if test 2654 -ne "`wc -c < 'shell.pas'`"
then
echo shar: error transmitting "'shell.pas'" '(should have been 2654 characters)'
fi
fi # end of overwriting check
if test -f 'toolu.pas'
then
echo shar: will not over-write existing file "'toolu.pas'"
else
cat << \SHAR_EOF > 'toolu.pas'
{toolu.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.
}
CONST
IOERROR=0;
STDIN=1;
STDOUT=2;
STDERR=3;
(*IO RELEATED STUFF*)
MAXOPEN=7;
IOREAD=0;
IOWRITE=1;
MAXCMD=20;
ENDFILE=255;
BLANK=32;
ENDSTR=0;
MAXSTR=100;
BACKSPACE=8;
TAB=9;
NEWLINE=10;
EXCLAM=33;
DQUOTE=34;
SHARP=35;
DOLLAR=36;
PERCENT=37;
AMPER=38;
SQUOTE=39;
ACUTE=SQUOTE;
LPAREN=40;
RPAREN=41;
STAR=42;
PLUS=43;
COMMA=44;
MINUS=45;
DASH=MINUS;
PERIOD=46;
SLASH=47;
COLON=58;
SEMICOL=59;
LESS=60;
EQUALS=61;
GREATER=62;
QUESTION=63;
ATSIGN=64;
ESCAPE=ATSIGN;
LBRACK=91;
BACKSLASH=92;
RBRACK=93;
CARET=94;
GRAVE=96;
UNDERLINE=95;
TILDE=126;
LBRACE=123;
BAR=124;
RBRACE=125;
TYPE
CHARACTER=0..255;
XSTRING=ARRAY[1..MAXSTR]OF CHARACTER;
STRING80=string[80];
FILEDESC=IOERROR..MAXOPEN;
FILTYP=(CLOSED,STDIO,FIL1,FIL2,FIL3,FIL4);
VAR
KBDN,KBDNEXT:INTEGER;
KBDLINE:XSTRING;
CMDARGS:0..MAXCMD;
CMDIDX:ARRAY[1..MAXCMD] OF 1..MAXSTR;
CMDLIN:XSTRING;
CMDLINE:STRING80;
CMDFIL:ARRAY[STDIN..MAXOPEN]OF FILTYP;
CMDOPEN:ARRAY[FILTYP]OF BOOLEAN;
FILE1,FILE2,FILE3,FILE4:TEXT;
FUNCTION GETKBD(VAR C:CHARACTER):CHARACTER;FORWARD;
FUNCTION FGETCF(VAR FIL:TEXT):CHARACTER;FORWARD;
FUNCTION GETCF(VAR C:CHARACTER;FD:FILEDESC):CHARACTER;FORWARD;
FUNCTION GETC(VAR C:CHARACTER):CHARACTER;FORWARD;
PROCEDURE FPUTCF(C:CHARACTER;VAR FIL:TEXT);FORWARD;
PROCEDURE PUTCF(C:CHARACTER;FD:FILEDESC);FORWARD;
PROCEDURE PUTC(C:CHARACTER);FORWARD;
PROCEDURE PUTDEC(N,W:INTEGER);FORWARD;
FUNCTION ITOC(N:INTEGER;VAR S:XSTRING;I:INTEGER):INTEGER;FORWARD;
FUNCTION GETARG(N:INTEGER;VAR S:XSTRING;
MAXSIZE:INTEGER):BOOLEAN;FORWARD;
PROCEDURE SCOPY(VAR SRC:XSTRING;I:INTEGER;VAR DEST:XSTRING;J:INTEGER);FORWARD;
PROCEDURE ENDCMD;FORWARD;
PROCEDURE XCLOSE(FD:FILEDESC);FORWARD;
FUNCTION MUSTCREATE(VAR NAME:XSTRING;MODE:INTEGER):
FILEDESC;FORWARD;
FUNCTION CREATE(VAR NAME:XSTRING;MODE:INTEGER):FILEDESC;FORWARD;
FUNCTION XLENGTH(VAR S:XSTRING):INTEGER;FORWARD;
PROCEDURE STRNAME(VAR STR:STRING80;VAR XSTR:XSTRING);FORWARD;
PROCEDURE ERROR(STR:STRING80);FORWARD;
FUNCTION MAX(X,Y:INTEGER):INTEGER;FORWARD;
PROCEDURE REMOVE(NAME:XSTRING);FORWARD;
FUNCTION GETLINE(VAR STR:XSTRING;FD:FILEDESC;
SIZE:INTEGER):BOOLEAN;FORWARD;
FUNCTION OPEN(VAR NAME:XSTRING;MODE:INTEGER):
FILEDESC;FORWARD;
FUNCTION FDALLOC:FILEDESC;FORWARD;
FUNCTION FTALLOC:FILTYP;FORWARD;
FUNCTION NARGS:INTEGER;FORWARD;
FUNCTION ADDSTR(C:CHARACTER;VAR OUTSET:XSTRING;
VAR J:INTEGER;MAXSET:INTEGER):BOOLEAN;FORWARD;
PROCEDURE PUTSTR(STR:XSTRING;FD:FILEDESC);FORWARD;
FUNCTION MUSTOPEN(VAR NAME:XSTRING;MODE:INTEGER):FILEDESC;FORWARD;
FUNCTION MIN(X,Y:INTEGER):INTEGER;FORWARD;
FUNCTION ISUPPER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION EQUAL(VAR STR1,STR2:XSTRING):BOOLEAN;FORWARD;
FUNCTION INDEX(VAR S:XSTRING;C:CHARACTER):INTEGER;FORWARD;
FUNCTION ISALPHANUM(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ESC(VAR S:XSTRING;VAR I:INTEGER):
CHARACTER;FORWARD;
PROCEDURE FCOPY(FIN,FOUT:FILEDESC);FORWARD;
FUNCTION CTOI(VAR S:XSTRING;VAR I:INTEGER):INTEGER;FORWARD;
FUNCTION ISDIGIT(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLOWER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLETTER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISDIGIT;
BEGIN
ISDIGIT:=C IN [ORD('0')..ORD('9')]
END;
FUNCTION ISLOWER;
BEGIN
ISLOWER:=C IN [97..122]
END;
FUNCTION ISLETTER;
BEGIN
ISLETTER:=C IN [65..90]+[97..122]
END;
FUNCTION CTOI;
VAR N,SIGN:INTEGER;
BEGIN
WHILE (S[I]=BLANK) OR (S[I]=TAB)DO
I:=I+1;
IF(S[I]=MINUS) THEN
SIGN:=-1
ELSE
SIGN:=1;
IF(S[I]=PLUS)OR(S[I]=MINUS)THEN
I:=I+1;
N:=0;
WHILE(ISDIGIT(S[I])) DO BEGIN
N:=10*N+S[I]-ORD('0');
I:=I+1
END;
CTOI:=SIGN*N
END;
PROCEDURE FCOPY;
VAR
C:CHARACTER;
BEGIN
WHILE(GETCF(C,FIN)<>ENDFILE) DO
PUTCF(C,FOUT)
END;
FUNCTION INDEX;
VAR I:INTEGER;
BEGIN
I:=1;
WHILE(S[I]<>C) AND (S[I]<>ENDSTR)DO
I:=I+1;
IF (S[I]=ENDSTR) THEN
INDEX:=0
ELSE
INDEX:=I
END;
FUNCTION ESC;
BEGIN
IF(S[I]<>ATSIGN) THEN
ESC:=S[I]
ELSE IF(S[I+1]=ENDSTR) THEN (*@ NOT SPECIAL AT END*)
ESC:=ATSIGN
ELSE BEGIN
I:=I+1;
IF(S[I]=ORD('N'))THEN ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
FUNCTION ISALPHANUM;
BEGIN
ISALPHANUM:=C IN
[ORD('A')..ORD('Z'),ORD('0')..ORD('9'),
97..122]
END;
FUNCTION MAX;
BEGIN
IF(X>Y)THEN
MAX:=X
ELSE
MAX:=Y
END;
FUNCTION MIN;
BEGIN
IF X<Y THEN
MIN:=X
ELSE
MIN:=Y
END;
FUNCTION ISUPPER;
BEGIN
ISUPPER:=C IN [ORD('A')..ORD('Z')]
END;
FUNCTION XLENGTH;
VAR
N:INTEGER;
BEGIN
N:=1;
WHILE(S[N]<>ENDSTR)DO
N:=N+1;
XLENGTH:=N-1
END;
FUNCTION GETARG;
BEGIN
IF((N<1)OR(CMDARGS<N))THEN
GETARG:=FALSE
ELSE BEGIN
SCOPY(CMDLIN,CMDIDX[N],S,1);
GETARG:=TRUE
END
END;(*GETARG*)
PROCEDURE SCOPY;
BEGIN
WHILE(SRC[I]<>ENDSTR)DO BEGIN
DEST[J]:=SRC[I];
I:=I+1;
J:=J+1
END;
DEST[J]:=ENDSTR;
END;
(*$I-*)
FUNCTION CREATE;
VAR
FD:FILEDESC;
SNM:STRING80;
BEGIN
FD:=FDALLOC;
IF(FD<>IOERROR)THEN BEGIN
STRNAME(SNM,NAME);
CASE (CMDFIL[FD])OF
FIL1:
begin assign(FILE1,SNM);rewrite(FILE1) end;
FIL2:begin assign(FILE2,SNM);rewrite(FILE2) end;
FIL3:begin assign(FILE3,SNM);rewrite(FILE3) end;
FIL4:begin assign(FILE4,SNM);rewrite(FILE4) end
END;
IF(IORESULT<>0)THEN BEGIN
XCLOSE(FD);
FD:=IOERROR
END
END;
CREATE:=FD;
END;
(*$I+*)
PROCEDURE STRNAME;
VAR I:INTEGER;
BEGIN
STR:='.PAS';
I:=1;
WHILE(XSTR[I]<>ENDSTR)DO BEGIN
INSERT('X',STR,I);
STR[I]:=CHR(XSTR[I]);
I:=I+1
END
END;
PROCEDURE ERROR;
BEGIN
WRITELN(STR);
HALT
END;
FUNCTION MUSTCREATE;
VAR
FD:FILEDESC;
BEGIN
FD:=CREATE(NAME,MODE);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
ERROR(' :CAN''T CREATE FILE')
END;
MUSTCREATE:=FD
END;
FUNCTION NARGS;
BEGIN
NARGS:=CMDARGS
END;
PROCEDURE REMOVE;
VAR
FD:FILEDESC;
BEGIN
FD:=OPEN(NAME,IOREAD);
IF(FD=IOERROR)THEN
WRITELN('CAN''T REMOVE FILE')
ELSE BEGIN
CASE (CMDFIL[FD]) OF
FIL1:CLOSE(FILE1);
FIL2:CLOSE(FILE2);
FIL3:CLOSE(FILE3);
FIL4:CLOSE(FILE4);
END
END;
CMDFIL[FD]:=CLOSED
END;
FUNCTION GETLINE;
VAR I,ii:INTEGER;
DONE:BOOLEAN;
CH:CHARACTER;
BEGIN
I:=0;
REPEAT
DONE:=TRUE;
CH:=GETCF(CH,FD);
IF(CH=ENDFILE) THEN
I:=0
ELSE IF (CH=NEWLINE) THEN BEGIN
I:=I+1;
STR[I]:=NEWLINE
END
ELSE IF (SIZE-2<=I) THEN BEGIN
WRITELN('LINE TOO LONG');
I:=I+1;
STR[I]:=NEWLINE
END
ELSE BEGIN
DONE:=FALSE;
I:=I+1;
STR[I]:=CH;
END
UNTIL(DONE);
STR[I+1]:=ENDSTR;
GETLINE:=(0<I)
END;(*GETLINE*)
(*$I-*)
FUNCTION OPEN;
VAR FD:FILEDESC;
SNM:STRING80;
BEGIN
FD:=FDALLOC;
IF(FD<>IOERROR) THEN BEGIN
STRNAME(SNM,NAME);
CASE (CMDFIL[FD]) OF
FIL1:begin assign(FILE1,SNM);RESET(FILE1) end;
FIL2:begin assign(FILE2,SNM);RESET(FILE2) end;
FIL3:begin assign(FILE3,SNM);RESET(FILE3) end;
FIL4:begin assign(FILE4,SNM);RESET(FILE4) end
END;
IF(IORESULT<>0) THEN BEGIN
XCLOSE(FD);
FD:=IOERROR
END
END;
OPEN:=FD
END;
(*$I+*)
FUNCTION FTALLOC;
VAR DONE:BOOLEAN;
FT:FILTYP;
BEGIN
FT:=FIL1;
REPEAT
DONE:=(NOT CMDOPEN[FT] OR (FT=FIL4));
IF(NOT DONE) THEN
FT:=SUCC(FT)
UNTIL (DONE);
IF(CMDOPEN[FT]) THEN
FTALLOC:=CLOSED
ELSE
FTALLOC:=FT
END;
FUNCTION FDALLOC;
VAR DONE:BOOLEAN;
FD:FILEDESC;
BEGIN
FD:=STDIN;
DONE:=FALSE;
WHILE(NOT DONE) DO
IF((CMDFIL[FD]=CLOSED) OR (FD=MAXOPEN))THEN
DONE:=TRUE
ELSE FD:=SUCC(FD);
IF(CMDFIL[FD]<>CLOSED) THEN
FDALLOC:=IOERROR
ELSE BEGIN
CMDFIL[FD]:=FTALLOC;
IF(CMDFIL[FD]=CLOSED) THEN
FDALLOC:=IOERROR
ELSE BEGIN
CMDOPEN[CMDFIL[FD]]:=TRUE;
FDALLOC:=FD
END
END
END;(*FDALLOC*)
PROCEDURE ENDCMD;
VAR FD:FILEDESC;
BEGIN
FOR FD:=STDIN TO MAXOPEN DO
XCLOSE(FD)
END;
PROCEDURE XCLOSE;
BEGIN
CASE (CMDFIL[FD])OF
CLOSED,STDIO:;
FIL1:CLOSE(FILE1);
FIL2:CLOSE(FILE2);
FIL3:CLOSE(FILE3);
FIL4:CLOSE(FILE4)
END;
CMDOPEN[CMDFIL[FD]]:=FALSE;
CMDFIL[FD]:=CLOSED
END;
FUNCTION ADDSTR;
BEGIN
IF(J>MAXSET)THEN
ADDSTR:=FALSE
ELSE BEGIN
OUTSET[J]:=C;
J:=J+1;
ADDSTR:=TRUE
END
END;
PROCEDURE PUTSTR;
VAR I:INTEGER;
BEGIN
I:=1;
WHILE(STR[I]<>ENDSTR) DO BEGIN
PUTCF(STR[I],FD);
I:=I+1
END
END;
FUNCTION MUSTOPEN;
VAR FD:FILEDESC;
BEGIN
FD:=OPEN(NAME,MODE);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
WRITELN(': CAN''T OPEN FILE')
END;
MUSTOPEN:=FD
END;
FUNCTION GETKBD;
VAR
DONE:BOOLEAN;
i:integer;
ch:char;
BEGIN
IF (KBDN<=0)
THEN
BEGIN
KBDNEXT:=1;
DONE:=FALSE;
if (kbdn=-2)
then
begin
readln;
kbdn:=0
end
else if (kbdn<0)
then
done:=true;
WHILE(NOT DONE)
DO
BEGIN
kbdn:=kbdn+1;
DONE:=TRUE;
if (eof(TRM))
then
kbdn:=-1
else if eoln(TRM)
then
begin
kbdline[kbdn]:=NEWLINE;
readln(TRM);
end
else if (MAXSTR-1<=kbdn)
then
begin
writeln('Line too long');
kbdline[kbdn]:=newline
end
ELSE
begin
read(TRM,ch);
kbdline[kbdn]:=ord(ch);
if (ord(ch)in [0..7,9..12,14..31])
then
write('^',chr(ord(ch)+64))
else if (kbdline[kbdn]<>BACKSPACE)
then
{do nothing}
ELSE
begin
write(ch,' ',ch);
if (1<kbdn)
then
begin
kbdn:=kbdn-2;
if kbdline[kbdn+1]in[0..31]
then
write(ch,' ',ch)
end
ELSE
kbdn:=kbdn-1
end;
done:=false
end;
END
END;
reset(TRM);
IF(KBDN<=0)
THEN
C:=ENDFILE
ELSE
BEGIN
C:=KBDLINE[KBDNEXT];
KBDNEXT:=KBDNEXT+1;
if (c=NEWLINE)
then
begin
reset(TRM);
kbdn:=-2;
end
ELSE
KBDN:=KBDN-1
END;
GETKBD:=C
END;
FUNCTION FGETCF;
VAR CH:CHAR;
BEGIN
IF(EOF(FIL))THEN
FGETCF:=ENDFILE
ELSE IF(EOLN(FIL)) THEN BEGIN
READLN(FIL);
FGETCF:=NEWLINE
END
ELSE BEGIN
READ(FIL,CH);
FGETCF:=ORD(CH);
END;
END;
FUNCTION GETCF;
BEGIN
CASE(CMDFIL[FD])OF
STDIO:C:=GETKBD(C);
FIL1:C:=FGETCF(FILE1);
FIL2:C:=FGETCF(FILE2);
FIL3:C:=FGETCF(FILE3);
FIL4:C:=FGETCF(FILE4);
END;
GETCF:=C
END;
FUNCTION GETC;
BEGIN
GETC:=GETCF(C,STDIN)
END;
PROCEDURE FPUTCF;
BEGIN
IF(C=NEWLINE)THEN
WRITELN(FIL)
ELSE
WRITE(FIL,CHR(C))
END;
PROCEDURE PUTCF;
BEGIN
CASE (CMDFIL[FD]) OF
STDIO:FPUTCF(C,CON);
FIL1:FPUTCF(C,FILE1);
FIL2:FPUTCF(C,FILE2);
FIL3:FPUTCF(C,FILE3);
FIL4:FPUTCF(C,FILE4)
END
END;
PROCEDURE PUTC;
BEGIN
PUTCF(C,STDOUT);
END;
FUNCTION ITOC;
BEGIN
IF(N<0)THEN BEGIN
S[I]:=ORD('-');
ITOC:=ITOC(-N,S,I+1);
END
ELSE BEGIN
IF (N>=10)THEN
I:=ITOC(N DIV 10,S, I);
S[I]:=N MOD 10 + ORD('0');
S[I+1]:=ENDSTR;
ITOC:=I+1;
END
END;
PROCEDURE PUTDEC;
VAR I,ND:INTEGER;
S:XSTRING;
BEGIN
ND:=ITOC(N,S,1);
FOR I:=ND TO W DO
PUTC(BLANK);
FOR I:=1 TO ND-1 DO
PUTC(S[I])
END;
FUNCTION EQUAL;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(STR1[I]=STR2[I])AND(STR1[I]<>ENDSTR) DO
I:=I+1;
EQUAL:=(STR1[I]=STR2[I])
END;
SHAR_EOF
if test 12173 -ne "`wc -c < 'toolu.pas'`"
then
echo shar: error transmitting "'toolu.pas'" '(should have been 12173 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0
More information about the Comp.sources.unix
mailing list