reintom@rocky2.UUCP (07/16/86)
#! /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:
# README.V30
# chapter1.pas
# chapter2.pas
# chapter3.pas
# chapter4.pas
# chapter5.pas
# chapter6.pas
# This archive created: Tue Jul 15 11:45:14 1986
export PATH; PATH=/bin:$PATH
if test -f 'README.V30'
then
echo shar: will not over-write existing file "'README.V30'"
else
cat << \SHAR_EOF > 'README.V30'
{readme.v30}
TURBTOOL.LBR DOCUMENTATION
This library contains the source from the book
"Software Tools in Pascal" by B.W. Kernighan and
P.J. Plauger, Addison-Wesley. It has been adapted
for Turbo Pascal.
How to Implement:
Compile SHELL.PAS with the CMD option
Execute SHELL
Accepts redirection, but not pipes.
Bill McGee, 613-828-9130
Notes: The version using TURBO is fast enough to make
this a useful set of tools for file manipulation.
------Further Modifications------
The primitives in this version are basically the UCSD Pascal versions
presented in the book, with modifications for Turbo Pascal.
This version has been modified for use under Turbo Pascal v. 3.0
under CP/M-86. There are no system dependent statements in the code
to the best of my knowledge, so it should work under MS-DOS as well.
The original version (typed in by Bill McGee) was set up for CP/M-80 and
used the CHAIN capability of Turbo Pascal. I have eliminated that
feature in favor of using INCLUDE files. There is not enough memory
available in a CP/M-80 system for this version, but one could modify
the include file list to eliminate unwanted features or to make more
than one version, (e.g. break out EDIT, FORMAT, and DEFINE).
There was really only one change required to the McGee's original to get
it to work with version 3.0. A readln(TRM) had to be added in the
subroutine GETKBD. The change to CP/M-86 required replacing all calls
to the procedure BDOS(0,0) with HALT. This change works with the CP/M-80
version of Turbo Pascal v. 3.0 as well. Thus, as anyone can see, all of
the hard work was done by Bill.
(Adaption to version 3.0 of Turbo Pascal by Jim Potter, (505) 662-5804.)
Please note that this is copyright software. The following notice has
been included with each file and should not be removed.
+-------------------------------------------------------------------------+
| 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. |
+-------------------------------------------------------------------------+
SHAR_EOF
if test 3049 -ne "`wc -c < 'README.V30'`"
then
echo shar: error transmitting "'README.V30'" '(should have been 3049 characters)'
fi
fi # end of overwriting check
if test -f 'chapter1.pas'
then
echo shar: will not over-write existing file "'chapter1.pas'"
else
cat << \SHAR_EOF > 'chapter1.pas'
{chapter1.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 COPY;
VAR C:CHARACTER;
BEGIN
WHILE(GETC(C)<>ENDFILE)DO
PUTC(C)
END;
PROCEDURE CHARCOUNT;
VAR
NC:INTEGER;
C:CHARACTER;
BEGIN
NC:=0;
WHILE (GETC(C)<>ENDFILE)DO
NC:=NC+1;
PUTDEC(NC,1);
PUTC(NEWLINE)
END;
PROCEDURE LINECOUNT;
VAR
N1:INTEGER;
C:CHARACTER;
BEGIN
N1:=0;
WHILE(GETC(C)<>ENDFILE)DO
IF(C=NEWLINE)THEN
N1:=N1+1;
PUTDEC(N1,1);
PUTC(NEWLINE)
END;
PROCEDURE WORDCOUNT;
VAR
NW:INTEGER;
C:CHARACTER;
INWORD:BOOLEAN;
BEGIN
NW:=0;
INWORD:=FALSE;
WHILE(GETC(C)<>ENDFILE)DO
IF(C=BLANK)OR(C=NEWLINE)OR(C=TAB) THEN
INWORD:=FALSE
ELSE IF (NOT INWORD)THEN BEGIN
INWORD:=TRUE;
NW:=NW+1
END;
PUTDEC(NW,1);
PUTC(NEWLINE)
END;
PROCEDURE DETAB;
CONST
MAXLINE=1000;
TYPE
TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
C:CHARACTER;
COL:INTEGER;
TABSTOPS:TABTYPE;
FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE)
:BOOLEAN;
BEGIN
IF(COL>MAXLINE)THEN
TABPOS:=TRUE
ELSE
TABPOS:=TABSTOPS[COL]
END;
PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
TABSPACE=4;
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO MAXLINE DO
TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;
BEGIN
SETTABS(TABSTOPS);
COL:=1;
WHILE(GETC(C)<>ENDFILE)DO
IF(C=TAB)THEN
REPEAT
PUTC(BLANK);
COL:=COL+1
UNTIL(TABPOS(COL,TABSTOPS))
ELSE IF(C=NEWLINE)THEN BEGIN
PUTC(NEWLINE);
COL:=1
END
ELSE BEGIN
PUTC(C);
COL:=COL+1
END
END;
SHAR_EOF
if test 2054 -ne "`wc -c < 'chapter1.pas'`"
then
echo shar: error transmitting "'chapter1.pas'" '(should have been 2054 characters)'
fi
fi # end of overwriting check
if test -f 'chapter2.pas'
then
echo shar: will not over-write existing file "'chapter2.pas'"
else
cat << \SHAR_EOF > 'chapter2.pas'
{chapter2.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 TRANSLIT;FORWARD;
PROCEDURE ENTAB;FORWARD;
PROCEDURE EXPAND;FORWARD;
PROCEDURE ECHO;FORWARD;
PROCEDURE COMPRESS;FORWARD;
PROCEDURE OVERSTRIKE;FORWARD;
PROCEDURE OVERSTRIKE;
CONST
SKIP=BLANK;
NOSKIP=PLUS;
VAR
C:CHARACTER;
COL,NEWCOL,I:INTEGER;
BEGIN
COL:=1;
REPEAT
NEWCOL:=COL;
WHILE(GETC(C)=BACKSPACE) DO
NEWCOL:=MAX(NEWCOL-1,1);
IF (NEWCOL<COL) THEN BEGIN
PUTC(NEWLINE);
PUTC(NOSKIP);
FOR I:=1 TO NEWCOL-1 DO
PUTC(BLANK);
COL:=NEWCOL
END
ELSE IF (COL=1) AND (C<>ENDFILE) THEN
PUTC(SKIP);
IF(C<>ENDFILE)THEN BEGIN
PUTC(C);
IF (C=NEWLINE) THEN
COL:=1
ELSE
COL:=COL+1
END
UNTIL (C=ENDFILE)
END;
PROCEDURE COMPRESS;
CONST
WARNING=CARET;
VAR
C,LASTC:CHARACTER;
N:INTEGER;
PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
MAXREP=26;
THRESH=4;
BEGIN
WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
PUTC(WARNING);
PUTC(MIN(N,MAXREP)-1+ORD('A'));
PUTC(C);
N:=N-MAXREP
END;
FOR N:=N DOWNTO 1 DO
PUTC(C)
END;
BEGIN(*COMPRESS*)
N:=1;
LASTC:=GETC(LASTC);
WHILE(LASTC<>ENDFILE) DO BEGIN
IF(GETC(C)=ENDFILE)THEN BEGIN
IF(N>1) OR(LASTC=WARNING) THEN
PUTREP(N,LASTC)
ELSE
PUTC(LASTC)
END
ELSE IF (C=LASTC) THEN
N:=N+1
ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
PUTREP(N,LASTC);
N:=1
END
ELSE
PUTC(LASTC);
LASTC:=C
END
END;
PROCEDURE EXPAND;
CONST
WARNING=CARET;
VAR
C:CHARACTER;
N:INTEGER;
BEGIN
WHILE(GETC(C)<>ENDFILE) DO
IF (C<>WARNING)THEN
PUTC(C)
ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
N:=C-ORD('A')+1;
IF(GETC(C)<>ENDFILE)THEN
FOR N:=N DOWNTO 1 DO
PUTC(C)
ELSE BEGIN
PUTC(WARNING);
PUTC(N-1+ORD('A'))
END
END
ELSE BEGIN
PUTC(WARNING);
IF(C<>ENDFILE) THEN
PUTC(C)
END
END;
PROCEDURE ECHO;
VAR
I,J:INTEGER;
ARGSTR:XSTRING;
BEGIN
I:=2;
WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
IF(I>1) THEN PUTC(BLANK);
FOR J:=1 TO XLENGTH(ARGSTR) DO
PUTC(ARGSTR[J]);
I:=I+1
END;
IF(I>1)THEN PUTC(NEWLINE)
END;
PROCEDURE ENTAB;
CONST
MAXLINE=1000;
TYPE
TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
C:CHARACTER;
COL,NEWCOL:INTEGER;
TABSTOPS:TABTYPE;
FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
BEGIN
IF(COL>MAXLINE)THEN
TABPOS:=TRUE
ELSE
TABPOS:=TABSTOPS[COL]
END;
PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
TABSPACE=4;
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO MAXLINE DO
TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;
BEGIN
SETTABS(TABSTOPS);
COL:=1;
REPEAT
NEWCOL:=COL;
WHILE(GETC(C)=BLANK) DO BEGIN
NEWCOL:=NEWCOL+1;
IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
PUTC(TAB);
COL:=NEWCOL;
END
END;
WHILE (COL<NEWCOL) DO BEGIN
PUTC(BLANK);
COL:=COL+1
END;
IF(C<>ENDFILE) THEN BEGIN
PUTC(C);
IF(C=NEWLINE) THEN
COL:=1
ELSE
COL:=COL+1
END
UNTIL(C=ENDFILE)
END;
PROCEDURE TRANSLIT;
CONST
NEGATE=CARET;
VAR
ARG,FROMSET,TOSET:XSTRING;
C:CHARACTER;
I,LASTTO:0..MAXSTR;
ALLBUT,SQUASH:BOOLEAN;
FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
BEGIN
IF(C=ENDFILE)THEN XINDEX:=0
ELSE IF (NOT ALLBUT) THEN
XINDEX:=INDEX(INSET,C)
ELSE IF(INDEX(INSET,C)>0)THEN
XINDEX:=0
ELSE
XINDEX:=LASTTO+1
END;
FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;
VAR J:INTEGER;
PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
VAR I:INTEGER;VAR DEST:XSTRING;
VAR J:INTEGER;MAXSET:INTEGER);
VAR
K:INTEGER;
JUNK:BOOLEAN;
BEGIN
WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
IF(SRC[I]=ATSIGN)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;(*DODASH*)
BEGIN(*MAKESET*)
J:=1;
DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
END;(*MAKESET*)
BEGIN(*TRANSLIT*)
IF (NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:TRANSLIT FROM TO');
ALLBUT:=(ARG[1]=NEGATE);
IF(ALLBUT)THEN
I:=2
ELSE
I:=1;
IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
ERROR('TRANSLIT:"FROM"SET TOO LARGE');
IF(NOT GETARG(3,ARG,MAXSTR))THEN
TOSET[1]:=ENDSTR
ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
ERROR('TRANSLIT:"TO"SET TOO LARGE')
ELSE IF (XLENGTH(FROMSET)<XLENGTH(TOSET))THEN
ERROR('TRANSLIT:"FROM"SHORTER THAN "TO');
LASTTO:=XLENGTH(TOSET);
SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
REPEAT
I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
PUTC(TOSET[LASTTO]);
REPEAT
I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
UNTIL (I<LASTTO)
END;
IF(C<>ENDFILE) THEN BEGIN
IF(I>0)AND(LASTTO>0) THEN
PUTC(TOSET[I])
ELSE IF (I=0)THEN
PUTC(C)
(*ELSE DELETE*)
END
UNTIL(C=ENDFILE)
END;
SHAR_EOF
if test 6124 -ne "`wc -c < 'chapter2.pas'`"
then
echo shar: error transmitting "'chapter2.pas'" '(should have been 6124 characters)'
fi
fi # end of overwriting check
if test -f 'chapter3.pas'
then
echo shar: will not over-write existing file "'chapter3.pas'"
else
cat << \SHAR_EOF > 'chapter3.pas'
{chapter3.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 COMPARE;FORWARD;
PROCEDURE INCLUDE;FORWARD;
PROCEDURE CONCAT;FORWARD;
PROCEDURE MAKECOPY;
VAR
INNAME,OUTNAME:XSTRING;
FIN,FOUT:FILEDESC;
BEGIN
IF(NOT GETARG(2,INNAME,MAXSTR))
OR (NOT GETARG(3,OUTNAME,MAXSTR))THEN
ERROR('USAGE:MAKECOPY OLD NEW');
FIN:=MUSTOPEN(INNAME,IOREAD);
FOUT:=MUSTCREATE(OUTNAME,IOWRITE);
FCOPY(FIN,FOUT);
XCLOSE(FIN);
XCLOSE(FOUT)
END;
PROCEDURE PRINT;
VAR
NAME:XSTRING;
NULL:XSTRING;
I:INTEGER;
FIN:FILEDESC;
JUNK:BOOLEAN;
PROCEDURE FPRINT(VAR NAME:XSTRING;FIN:FILEDESC);
CONST
MARGIN1=2;
MARGIN2=2;
BOTTOM=64;
PAGELEN=66;
VAR
LINE:XSTRING;
LINENO,PAGENO:INTEGER;
PROCEDURE SKIP(N:INTEGER);
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO N DO
PUTC(NEWLINE)
END;
PROCEDURE HEAD(VAR NAME:XSTRING;PAGENO:INTEGER);
VAR
PAGE:XSTRING;
BEGIN
PAGE[1]:=ORD(' ');
PAGE[2]:=ORD('P');
PAGE[3]:=ORD('a');
PAGE[4]:=ORD('g');
PAGE[5]:=ORD('e');
PAGE[6]:=ORD(' ');
PAGE[7]:=ENDSTR;
PUTSTR(NAME,STDOUT);
PUTSTR(PAGE,STDOUT);
PUTDEC(PAGENO,1);
PUTC(NEWLINE)
END;
BEGIN(*FPRINT*)
PAGENO:=1;
SKIP(MARGIN1);
HEAD(NAME,PAGENO);
SKIP(MARGIN2);
LINENO:=MARGIN1+MARGIN2+1;
WHILE(GETLINE(LINE,FIN,MAXSTR))DO BEGIN
IF(LINENO=0)THEN BEGIN
SKIP(MARGIN1);;
PAGENO:=PAGENO+1;
HEAD(NAME,PAGENO);
SKIP(MARGIN2);
LINENO:=MARGIN1+MARGIN2+1
END;
PUTSTR(LINE,STDOUT);
LINENO:=LINENO+1;
IF(LINENO>=BOTTOM)THEN BEGIN
SKIP(PAGELEN-LINENO);
LINENO:=0
END
END;
IF(LINENO>0)THEN
SKIP(PAGELEN-LINENO)
END;
BEGIN(*PRINT*)
NULL[1]:=ENDSTR;
IF(NARGS=1)THEN
FPRINT(NULL,STDIN)
ELSE
FOR I:=2 TO NARGS DO BEGIN
JUNK:=GETARG(I,NAME,MAXSTR);
FIN:=MUSTOPEN(NAME,IOREAD);
FPRINT(NAME,FIN);
XCLOSE(FIN)
END
END;
PROCEDURE COMPARE;
VAR
LINE1,LINE2:XSTRING;
ARG1,ARG2:XSTRING;
LINENO:INTEGER;
INFILE1,INFILE2:FILEDESC;
F1,F2:BOOLEAN;
PROCEDURE DIFFMSG (N:INTEGER; VAR LINE1,LINE2:XSTRING);
BEGIN
PUTDEC(N,1);
PUTC(COLON);
PUTC(NEWLINE);
PUTSTR(LINE1,STDOUT);
PUTSTR(LINE2,STDOUT)
END;
BEGIN(*COMPARE*)
IF (NOT GETARG(2,ARG1,MAXSTR))
OR (NOT GETARG(3,ARG2,MAXSTR)) THEN
ERROR('USAGE:COMPARE FILE1 FILE2');
INFILE1:=MUSTOPEN(ARG1,IOREAD);
INFILE2:=MUSTOPEN(ARG2,IOREAD);
LINENO:=0;
REPEAT
LINENO:=LINENO+1;
F1:=GETLINE(LINE1,INFILE1,MAXSTR);
F2:=GETLINE(LINE2,INFILE2,MAXSTR);
IF (F1 AND F2) THEN
IF (NOT EQUAL(LINE1,LINE2)) THEN
DIFFMSG(LINENO,LINE1,LINE2)
UNTIL (F1=FALSE) OR (F2=FALSE);
IF(F2 AND NOT F1) THEN
WRITELN('COMPARE:END OF FILE ON FILE 1')
ELSE IF (F1 AND NOT F2) THEN
WRITELN('COMPARE:END OF FILE ON FILE2')
END;
PROCEDURE INCLUDE;
VAR
INCL:XSTRING;
PROCEDURE FINCLUDE(F:FILEDESC);
VAR
LINE,STR:XSTRING;
LOC,I:INTEGER;
F1:FILEDESC;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
BEGIN
WHILE (GETLINE(LINE,F,MAXSTR))DO BEGIN
LOC:=GETWORD(LINE,1,STR);
IF (NOT EQUAL(STR,INCL)) THEN
PUTSTR(LINE,STDOUT)
ELSE BEGIN
LOC:=GETWORD(LINE,LOC,STR);
STR[XLENGTH(STR)]:=ENDSTR;
FOR I:= 1 TO XLENGTH(STR)DO
STR[I]:=STR[I+1];
F1:=MUSTOPEN(STR,IOREAD);
FINCLUDE(F1);
XCLOSE(F1)
END
END
END;
BEGIN
INCL[1]:=ORD('#');
INCL[2]:=ORD('i');
INCL[3]:=ORD('n');
INCL[4]:=ORD('c');
INCL[5]:=ORD('l');
INCL[6]:=ORD('u');
INCL[7]:=ORD('d');
INCL[8]:=ORD('e');
INCL[9]:=ENDSTR;
FINCLUDE(STDIN)
END;
PROCEDURE CONCAT;
VAR
I:INTEGER;
JUNK:BOOLEAN;
FD:FILEDESC;
S:XSTRING;
BEGIN
FOR I:=2 TO NARGS DO BEGIN
JUNK:=GETARG(I,S,MAXSTR);
FD:=MUSTOPEN(S,IOREAD);
FCOPY(FD,STDOUT);
XCLOSE(FD)
END
END;
PROCEDURE ARCHIVE;
CONST
MAXFILES=10;
VAR
ANAME:XSTRING;
CMD:XSTRING;
FNAME:ARRAY[1..MAXFILES]OF XSTRING;
FSTAT:ARRAY[1..MAXFILES] OF BOOLEAN;
NFILES:INTEGER;
ERRCOUNT:INTEGER;
ARCHTEMP:XSTRING;
ARCHHDR:XSTRING;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE (S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
FUNCTION GETHDR(FD:FILEDESC;VAR BUF,NAME:XSTRING;
VAR SIZE:INTEGER):BOOLEAN;
VAR
TEMP:XSTRING;
I:INTEGER;
BEGIN
IF(GETLINE(BUF,FD,MAXSTR)=FALSE)THEN
GETHDR:=FALSE
ELSE BEGIN
I:=GETWORD(BUF,1,TEMP);
IF(NOT EQUAL(TEMP,ARCHHDR))THEN
ERROR('ARCHIVE NOT IN PROPER FORMAT');
I:=GETWORD(BUF,I,NAME);
SIZE:=CTOI(BUF,I);
GETHDR:=TRUE
END
END;
FUNCTION FILEARG (VAR NAME:XSTRING):BOOLEAN;
VAR
I:INTEGER;
FOUND:BOOLEAN;
BEGIN
IF(NFILES<=0)THEN
FILEARG:=TRUE
ELSE BEGIN
FOUND:=FALSE;
I:=1;
WHILE(NOT FOUND) AND (I<=NFILES)DO BEGIN
IF(EQUAL(NAME,FNAME[I])) THEN BEGIN
FSTAT[I]:=TRUE;
FOUND:=TRUE
END;
I:=I+1
END;
FILEARG:=FOUND
END
END;
PROCEDURE FSKIP(FD:FILEDESC;N:INTEGER);
VAR
C:CHARACTER;
I:INTEGER;
BEGIN
FOR I:=1 TO N DO
IF(GETCF(C,FD)=ENDFILE)THEN
ERROR('ARCHIVE:END OF FILE IN FSKIP')
END;
PROCEDURE FMOVE(VAR NAME1,NAME2:XSTRING);
VAR
FD1,FD2:FILEDESC;
BEGIN
FD1:=MUSTOPEN(NAME1,IOREAD);
FD2:=MUSTCREATE(NAME2,IOWRITE);
FCOPY(FD1,FD2);
XCLOSE(FD1);
XCLOSE(FD2)
END;
PROCEDURE ACOPY(FDI,FDO:FILEDESC;N:INTEGER);
VAR
C:CHARACTER;
I:INTEGER;
BEGIN
FOR I:=1 TO N DO
IF (GETCF(C,FDI)=ENDFILE)THEN
ERROR('ARCHIVE: END OF FILE IN ACOPY')
ELSE
PUTCF(C,FDO)
END;
PROCEDURE NOTFOUND;
VAR
I:INTEGER;
BEGIN
FOR I := 1 TO NFILES DO
IF(FSTAT[I]=FALSE)THEN BEGIN
PUTSTR(FNAME[I],STDERR);
WRITELN(':NOT IN ARCHIVE');
ERRCOUNT:=ERRCOUNT + 1
END
END;
PROCEDURE ADDFILE(VAR NAME:XSTRING;FD:FILEDESC);
VAR
HEAD:XSTRING;
NFD:FILEDESC;
PROCEDURE MAKEHDR(VAR NAME,HEAD:XSTRING);
VAR
I:INTEGER;
FUNCTION FSIZE(VAR NAME:XSTRING):INTEGER;
VAR
C:CHARACTER;
FD:FILEDESC;
N:INTEGER;
BEGIN
N:=0;
FD:=MUSTOPEN(NAME,IOREAD);
WHILE(GETCF(C,FD)<>ENDFILE)DO
N:=N+1;
XCLOSE(FD);
FSIZE:=N
END;
BEGIN
SCOPY(ARCHHDR,1,HEAD,1);
I:=XLENGTH(HEAD)+1;
HEAD[I]:=BLANK;
SCOPY(NAME,1,HEAD,I+1);
I:=XLENGTH(HEAD)+1;
HEAD[I]:=BLANK;
I:=ITOC(FSIZE(NAME),HEAD,I+1);
HEAD[I]:=NEWLINE;
HEAD[I+1]:=ENDSTR
END;
BEGIN
NFD:=OPEN(NAME,IOREAD);
IF(NFD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
WRITELN(':CAN''T ADD');
ERRCOUNT:=ERRCOUNT+1
END;
IF(ERRCOUNT=0)THEN BEGIN
MAKEHDR(NAME,HEAD);
PUTSTR(HEAD,FD);
FCOPY(NFD,FD);
XCLOSE(NFD)
END
END;
PROCEDURE REPLACE(AFD,TFD:FILEDESC;CMD:INTEGER);
VAR
PINLINE,UNAME:XSTRING;
SIZE:INTEGER;
BEGIN
WHILE(GETHDR(AFD,PINLINE,UNAME,SIZE))DO
IF(FILEARG(UNAME))THEN BEGIN
IF(CMD=ORD('U'))THEN
ADDFILE(UNAME,TFD);
FSKIP(AFD,SIZE)
END
ELSE BEGIN
PUTSTR(PINLINE,TFD);
ACOPY(AFD,TFD,SIZE)
END
END;
PROCEDURE HELP;
BEGIN
ERROR('USAGE:ARCHIVE -[CDPTUX] ARCHNAME [FILES...]')
END;
PROCEDURE GETFNS;
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
ERRCOUNT:=0;
NFILES:=NARGS-3;
IF(NFILES>MAXFILES)THEN
ERROR('ARCHIVE:TO MANY FILE NAMES');
FOR I:=1 TO NFILES DO
JUNK:=GETARG(I+3,FNAME[I],MAXSTR);
FOR I:=1 TO NFILES DO
FSTAT[I]:=FALSE;
FOR I:=1 TO NFILES-1 DO
FOR J:=I+1 TO NFILES DO
IF(EQUAL(FNAME[I],FNAME[J]))THEN BEGIN
PUTSTR(FNAME[I],STDERR);
ERROR(':DUPLICATE FILENAME')
END
END;
PROCEDURE UPDATE(VAR ANAME:XSTRING;CMD:CHARACTER);
VAR
I:INTEGER;
AFD,TFD:FILEDESC;
BEGIN
TFD:=MUSTCREATE(ARCHTEMP,IOWRITE);
IF(CMD=ORD('u')) THEN BEGIN
AFD:=MUSTOPEN(ANAME,IOREAD);
REPLACE(AFD,TFD,ORD('u'));(*UPDATE EXISTING*)
XCLOSE(AFD)
END;
FOR I:=1 TO NFILES DO
IF(FSTAT[I]=FALSE)THEN BEGIN
ADDFILE(FNAME[I],TFD);
FSTAT[I]:=TRUE
END;
XCLOSE(TFD);
IF(ERRCOUNT=0)THEN
FMOVE(ARCHTEMP,ANAME)
ELSE
WRITELN('FATAL ERRORS - ARCHIVE NOT ALTERED');
REMOVE (ARCHTEMP)
END;
PROCEDURE TABLE(VAR ANAME:XSTRING);
VAR
HEAD,NAME:XSTRING;
SIZE:INTEGER;
AFD:FILEDESC;
PROCEDURE TPRINT(VAR BUF:XSTRING);
VAR
I:INTEGER;
TEMP:XSTRING;
BEGIN
I:=GETWORD(BUF,1,TEMP);
I:=GETWORD(BUF,I,TEMP);
PUTSTR(TEMP,STDOUT);
PUTC(BLANK);
I:=GETWORD(BUF,I,TEMP);(*SIZE*)
PUTSTR(TEMP,STDOUT);
PUTC(NEWLINE)
END;
BEGIN
AFD:=MUSTOPEN(ANAME,IOREAD);
WHILE(GETHDR(AFD,HEAD,NAME,SIZE))DO BEGIN
IF(FILEARG(NAME))THEN
TPRINT(HEAD);
FSKIP(AFD,SIZE)
END;
NOTFOUND
END;
PROCEDURE EXTRACT (VAR ANAME:XSTRING;CMD:CHARACTER);
VAR
ENAME,PINLINE:XSTRING;
AFD,EFD:FILEDESC;
SIZE : INTEGER;
BEGIN
AFD:=MUSTOPEN(ANAME,IOREAD);
IF (CMD=ORD('p')) THEN
EFD:=STDOUT
ELSE
EFD:=IOERROR;
WHILE (GETHDR(AFD,PINLINE,ENAME,SIZE)) DO
IF (NOT FILEARG(ENAME))THEN
FSKIP(AFD,SIZE)
ELSE
BEGIN
IF (EFD<> STDOUT) THEN
EFD:=CREATE(ENAME,IOWRITE);
IF(EFD=IOERROR) THEN BEGIN
PUTSTR(ENAME,STDERR);
WRITELN(': CANT''T CREATE');
ERRCOUNT:=ERRCOUNT+1;
FSKIP(AFD,SIZE)
END
ELSE BEGIN
ACOPY(AFD,EFD,SIZE);
IF(EFD<>STDOUT)THEN
XCLOSE(EFD)
END
END;
NOTFOUND
END;
PROCEDURE DELETE(VAR ANAME:XSTRING);
VAR
AFD,TFD:FILEDESC;
BEGIN
IF(NFILES<=0)THEN(*PROTECT INNOCENT*)
ERROR('ARCHIVE:-D REQUIRES EXPLICIT FILE NAMES');
AFD:=MUSTOPEN(ANAME,IOREAD);
TFD:=MUSTCREATE(ARCHTEMP,IOWRITE);
REPLACE(AFD,TFD,ORD('d'));
NOTFOUND;
XCLOSE(AFD);
XCLOSE(TFD);
IF(ERRCOUNT=0)THEN
FMOVE(ARCHTEMP,ANAME)
ELSE
WRITELN('FATAL ERRORS - ARCHIVE NOT ALTERED');
REMOVE(ARCHTEMP)
END;
PROCEDURE INITARCH;
BEGIN
ARCHTEMP[1]:=ORD('A');
ARCHTEMP[2]:=ORD('R');
ARCHTEMP[3]:=ORD('T');
ARCHTEMP[4]:=ORD('E');
ARCHTEMP[5]:=ORD('M');
ARCHTEMP[6]:=ORD('P');
ARCHTEMP[7]:=ENDSTR;
ARCHHDR[1]:=ORD('-');
ARCHHDR[2]:=ORD('H');
ARCHHDR[3]:=ORD('-');
ARCHHDR[4]:=ENDSTR;
END;
BEGIN
INITARCH;
IF (NOT GETARG(2,CMD,MAXSTR))
OR(NOT GETARG(3,ANAME,MAXSTR)) THEN
HELP;
GETFNS;
IF(XLENGTH(CMD)<>2) OR(CMD[1]<>ORD('-')) THEN
HELP
ELSE IF (CMD[2]=ORD('c'))OR(CMD[2]=ORD('u'))THEN
UPDATE(ANAME,CMD[2])
ELSE IF (CMD[2]=ORD('t'))THEN
TABLE(ANAME)
ELSE IF (CMD[2]=ORD('x'))OR(CMD[2]=ORD('p'))THEN
EXTRACT(ANAME,CMD[2])
ELSE IF (CMD[2]=ORD('d'))THEN
DELETE(ANAME)
ELSE
HELP
END;
SHAR_EOF
if test 11306 -ne "`wc -c < 'chapter3.pas'`"
then
echo shar: error transmitting "'chapter3.pas'" '(should have been 11306 characters)'
fi
fi # end of overwriting check
if test -f 'chapter4.pas'
then
echo shar: will not over-write existing file "'chapter4.pas'"
else
cat << \SHAR_EOF > 'chapter4.pas'
{chapter4.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 SORT;
CONST
MAXCHARS=10000;
MAXLINES=300;
MERGEORDER=5;
TYPE
CHARPOS=1..MAXCHARS;
CHARBUF=ARRAY[1..MAXCHARS] OF CHARACTER;
POSBUF=ARRAY[1..MAXLINES] OF CHARPOS;
POS=0..MAXLINES;
FDBUF=ARRAY[1..MERGEORDER]OF FILEDESC;
VAR
LINEBUF:CHARBUF;
LINEPOS:POSBUF;
NLINES:POS;
INFILE:FDBUF;
OUTFILE:FILEDESC;
HIGH,LOW,LIM:INTEGER;
DONE:BOOLEAN;
NAME:XSTRING;
FUNCTION GTEXT(VAR LINEPOS:POSBUF;VAR NLINES:POS;
VAR LINEBUF:CHARBUF;INFILE:FILEDESC):BOOLEAN;
VAR
I,LEN,NEXTPOS:INTEGER;
TEMP:XSTRING;
DONE:BOOLEAN;
BEGIN
NLINES:=0;
NEXTPOS:=1;
REPEAT
DONE:=(GETLINE(TEMP,INFILE,MAXSTR)=FALSE);
IF(NOT DONE) THEN BEGIN
NLINES:=NLINES+1;
LINEPOS[NLINES]:=NEXTPOS;
LEN:=XLENGTH(TEMP);
FOR I:=1 TO LEN DO
LINEBUF[NEXTPOS+I-1]:=TEMP[I];
LINEBUF[NEXTPOS+LEN]:=ENDSTR;
NEXTPOS:=NEXTPOS+LEN+1
END
UNTIL (DONE) OR (NEXTPOS>= MAXCHARS-MAXSTR)
OR (NLINES>=MAXLINES);
GTEXT:=DONE
END;
PROCEDURE PTEXT(VAR LINEPOS:POSBUF;NLINES:INTEGER;
VAR LINEBUF:CHARBUF;OUTFILE:FILEDESC);
VAR
I,J:INTEGER;
BEGIN
FOR I:=1 TO NLINES DO BEGIN
J:=LINEPOS[I];
WHILE (LINEBUF[J]<>ENDSTR)DO BEGIN
PUTCF(LINEBUF[J],OUTFILE);
J:=J+1
END
END
END;
PROCEDURE EXCHANGE(VAR LP1,LP2:CHARPOS);
VAR
TEMP:CHARPOS;
BEGIN
TEMP:=LP1;
LP1:=LP2;
LP2:=TEMP
END;
FUNCTION CMP (I,J:CHARPOS;VAR LINEBUF:CHARBUF)
:INTEGER;
BEGIN
WHILE(LINEBUF[I]=LINEBUF[J])
AND (LINEBUF[I]<>ENDSTR) DO BEGIN
I:=I+1;
J:=J+1
END;
IF(LINEBUF[I]=LINEBUF[J]) THEN
CMP:=0
ELSE IF (LINEBUF[I]=ENDSTR) THEN
CMP:=-1
ELSE IF (LINEBUF[J]=ENDSTR) THEN
CMP:=+1
ELSE IF (LINEBUF[I]<LINEBUF[J]) THEN
CMP:=-1
ELSE
CMP:=+1
END;(*CMP*)
PROCEDURE QUICK(VAR LINEPOS:POSBUF; NLINE:POS;
VAR LINEBUF:CHARBUF);
PROCEDURE RQUICK(LO,HI:INTEGER);
VAR
I,J:INTEGER;
PIVLINE:CHARPOS;
BEGIN
IF (LO<HI) THEN BEGIN
I:=LO;
J:=HI;
PIVLINE:=LINEPOS[J];
REPEAT
WHILE (I<J)
AND (CMP(LINEPOS[I],PIVLINE,LINEBUF)<=0) DO
I:=I+1;
WHILE (J>I)
AND (CMP(LINEPOS[J],PIVLINE,LINEBUF)>=0) DO
J:=J-1;
IF(I<J) THEN
(*OUT OF ORDER PAIR*)
EXCHANGE(LINEPOS[I],LINEPOS[J])
UNTIL (I>=J);
EXCHANGE(LINEPOS[I],LINEPOS[HI]);
IF(I-LO<HI-I) THEN BEGIN
RQUICK(LO,I-1);
RQUICK(I+1,HI)
END
ELSE BEGIN
RQUICK(I+1,HI);
RQUICK(LO,I-1)
END
END
END;(*RQUICK*)
BEGIN(*QUICK*)
RQUICK(1,NLINES)
END;
PROCEDURE GNAME(N:INTEGER;VAR NAME:XSTRING);
VAR
JUNK:INTEGER;
BEGIN
NAME[1]:=ORD('S');
NAME[2]:=ORD('T');
NAME[3]:=ORD('E');
NAME[4]:=ORD('M');
NAME[5]:=ORD('P');
NAME[6]:=ENDSTR;
JUNK:=ITOC(N,NAME,XLENGTH(NAME)+1)
END;
PROCEDURE GOPEN(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
NAME:XSTRING;
I:1..MERGEORDER;
BEGIN
FOR I:=1 TO F2-F1+1 DO BEGIN
GNAME(F1+I-1,NAME);
INFILE[I]:=MUSTOPEN(NAME,IOREAD)
END
END;
PROCEDURE GREMOVE(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
NAME:XSTRING;
I:1..MERGEORDER;
BEGIN
FOR I:= 1 TO F2-F1+1 DO BEGIN
XCLOSE(INFILE[I]);
GNAME(F1+I-1,NAME);
REMOVE(NAME)
END
END;
FUNCTION MAKEFILE(N:INTEGER):FILEDESC;
VAR
NAME:XSTRING;
BEGIN
GNAME(N,NAME);
MAKEFILE:=MUSTCREATE(NAME,IOWRITE)
END;
PROCEDURE MERGE(VAR INFILE:FDBUF; NF:INTEGER;
OUTFILE:FILEDESC);
VAR
I,J:INTEGER;
LBP:CHARPOS;
TEMP:XSTRING;
PROCEDURE REHEAP(VAR LINEPOS:POSBUF;NF:POS;
VAR LINEBUF:CHARBUF);
VAR
I,J:INTEGER;
BEGIN
I:=1;
J:=2*I;
WHILE(J<=NF)DO BEGIN
IF(J<NF) THEN
IF(CMP(LINEPOS[J],LINEPOS[J+1],LINEBUF)>0)THEN
J:=J+1;
IF(CMP(LINEPOS[I],LINEPOS[J],LINEBUF)<=0)THEN
I:=NF
ELSE
EXCHANGE(LINEPOS[I],LINEPOS[J]);(*PERCOLATE*)
I:=J;
J:=2*I
END
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;
BEGIN(*MERGE*)
J:=0;
FOR I:=1 TO NF DO
IF(GETLINE(TEMP,INFILE[I],MAXSTR)) THEN BEGIN
LBP:=(I-1)*MAXSTR+1;
SCCOPY(TEMP,LINEBUF,LBP);
LINEPOS[I]:=LBP;
J:=J+1
END;
NF:=J;
QUICK(LINEPOS,NF,LINEBUF);
WHILE (NF>0) DO BEGIN
LBP:=LINEPOS[1];
CSCOPY(LINEBUF,LBP,TEMP);
PUTSTR(TEMP,OUTFILE);
I:=LBP DIV MAXSTR +1;
IF (GETLINE(TEMP,INFILE[I],MAXSTR))THEN
SCCOPY(TEMP,LINEBUF,LBP)
ELSE BEGIN
LINEPOS[1]:=LINEPOS[NF];
NF:=NF-1
END;
REHEAP(LINEPOS,NF,LINEBUF)
END
END;
BEGIN
HIGH:=0;
REPEAT (*INITIAL FORMTION OF RUNS*)
DONE:=GTEXT(LINEPOS,NLINES,LINEBUF,STDIN);
QUICK(LINEPOS,NLINES,LINEBUF);
HIGH:=HIGH+1;
OUTFILE:=MAKEFILE(HIGH);
PTEXT(LINEPOS,NLINES,LINEBUF,OUTFILE);
XCLOSE(OUTFILE)
UNTIL (DONE);
LOW:=1;
WHILE (LOW<HIGH) DO BEGIN
LIM:=MIN(LOW+MERGEORDER-1,HIGH);
GOPEN(INFILE,LOW,LIM);
HIGH:=HIGH+1;
OUTFILE:=MAKEFILE(HIGH);
MERGE(INFILE,LIM-LOW+1,OUTFILE);
XCLOSE(OUTFILE);
GREMOVE(INFILE,LOW,LIM);
LOW:=LOW+MERGEORDER
END;
GNAME(HIGH,NAME);
OUTFILE:=OPEN(NAME,IOREAD);
FCOPY(OUTFILE,STDOUT);
XCLOSE(OUTFILE);
REMOVE(NAME)
END;
PROCEDURE UNIQUE;
VAR
BUF:ARRAY[0..1] OF XSTRING;
CUR:0..1;
BEGIN
CUR:=1;
BUF[1-CUR][1]:=ENDSTR;
WHILE (GETLINE(BUF[CUR],STDIN,MAXSTR))DO
IF (NOT EQUAL (BUF[CUR],BUF[1-CUR])) THEN BEGIN
PUTSTR(BUF[CUR],STDOUT);
CUR:=1-CUR
END
END;
PROCEDURE KWIC;
CONST
FOLD=DOLLAR;
VAR
BUF:XSTRING;
PROCEDURE PUTROT(VAR BUF:XSTRING);
VAR I:INTEGER;
PROCEDURE ROTATE(VAR BUF:XSTRING;N:INTEGER);
VAR I:INTEGER;
BEGIN
I:=N;
WHILE (BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
PUTC(BUF[I]);
I:=I+1
END;
PUTC(FOLD);
FOR I:=1 TO N-1 DO
PUTC(BUF[I]);
PUTC(NEWLINE)
END;(*ROTATE*)
BEGIN(*PUTROT*)
I:=1;
WHILE(BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
IF (ISALPHANUM(BUF[I])) THEN BEGIN
ROTATE(BUF,I);(*TOKEN STATRS AT "I"*)
REPEAT
I:=I+1
UNTIL (NOT ISALPHANUM(BUF[I]))
END;
I:=I+1
END
END;(*PUTROT*)
BEGIN(*KWIC*)
WHILE(GETLINE(BUF,STDIN,MAXSTR))DO
PUTROT(BUF)
END;
PROCEDURE UNROTATE;
CONST
MAXOUT=80;
MIDDLE=40;
FOLD=DOLLAR;
VAR
INBUF,OUTBUF:XSTRING;
I,J,F:INTEGER;
BEGIN
WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO BEGIN
FOR I:=1 TO MAXOUT-1 DO
OUTBUF[I]:=BLANK;
F:=INDEX(INBUF,FOLD);
J:=MIDDLE-1;
FOR I:=XLENGTH(INBUF)-1 DOWNTO F+1 DO BEGIN
OUTBUF[J]:=INBUF[I];
J:=J-1;
IF(J<=0)THEN
J:=MAXOUT-1
END;
J:=MIDDLE+1;
FOR I:=1 TO F-1 DO BEGIN
OUTBUF[J]:=INBUF[I];
J:=J MOD (MAXOUT-1) +1
END;
FOR J:=1 TO MAXOUT-1 DO
IF(OUTBUF[J]<>BLANK) THEN
I:=J;
OUTBUF[I+1]:=ENDSTR;
PUTSTR(OUTBUF,STDOUT);
PUTC(NEWLINE)
END
END;
SHAR_EOF
if test 7602 -ne "`wc -c < 'chapter4.pas'`"
then
echo shar: error transmitting "'chapter4.pas'" '(should have been 7602 characters)'
fi
fi # end of overwriting check
if test -f 'chapter5.pas'
then
echo shar: will not over-write existing file "'chapter5.pas'"
else
cat << \SHAR_EOF > 'chapter5.pas'
{chapter5.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;
PROCEDURE FIND;
VAR
ARG,LIN,PAT:XSTRING;
FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;
BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
BEGIN
IF(NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:FIND PATTERN');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('FIND:ILLEGAL PATTERN');
WHILE(GETLINE(LIN,STDIN,MAXSTR))DO
IF (MATCH(LIN,PAT))THEN
PUTSTR(LIN,STDOUT)
END;
PROCEDURE CHANGE;
CONST
DITTO=255;
VAR
LIN,PAT,SUB,ARG:XSTRING;
FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;
BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
FUNCTION GETSUB(VAR ARG,SUB:XSTRING):BOOLEAN;
FUNCTION MAKESUB(VAR ARG:XSTRING; FROM:INTEGER;
DELIM:CHARACTER; VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE (ARG[I]<>DELIM) AND (ARG[I]<>ENDSTR) DO BEGIN
IF(ARG[I]=ORD('&')) THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF (ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT)) THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;
BEGIN
GETSUB:=(MAKESUB(ARG,1,ENDSTR,SUB)>0)
END;
PROCEDURE SUBLINE(VAR LIN,PAT,SUB:XSTRING);
VAR
I, LASTM, M:INTEGER;
JUNK:BOOLEAN;
PROCEDURE PUTSUB(VAR LIN:XSTRING; S1,S2:INTEGER;
VAR SUB:XSTRING);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE (SUB[I]<>ENDSTR) DO BEGIN
IF(SUB[I]=DITTO) THEN
FOR J:=S1 TO S2-1 DO
PUTC(LIN[J])
ELSE
PUTC(SUB[I]);
I:=I+1
END
END;
BEGIN
LASTM:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) DO BEGIN
M:=AMATCH(LIN,I,PAT,1);
IF (M>0) AND (LASTM<>M) THEN BEGIN
PUTSUB(LIN,I,M,SUB);
LASTM:=M
END;
IF (M=0) OR (M=I) THEN BEGIN
PUTC(LIN[I]);
I:=I+1
END
ELSE
I:=M
END
END;
BEGIN
IF(NOT GETARG(2,ARG,MAXSTR)) THEN
ERROR('USAGE:CHANGE FROM [TO]');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('CHANGE:ILLEGAL "FROM" PATTERN');
IF (NOT GETARG(3,ARG,MAXSTR)) THEN
ARG[1]:=ENDSTR;
IF(NOT GETSUB(ARG,SUB)) THEN
ERROR('CHANGE:ILLEGAL "TO" STRING');
WHILE (GETLINE(LIN,STDIN,MAXSTR)) DO
SUBLINE(LIN,PAT,SUB)
END;
SHAR_EOF
if test 8365 -ne "`wc -c < 'chapter5.pas'`"
then
echo shar: error transmitting "'chapter5.pas'" '(should have been 8365 characters)'
fi
fi # end of overwriting check
if test -f 'chapter6.pas'
then
echo shar: will not over-write existing file "'chapter6.pas'"
else
cat << \SHAR_EOF > 'chapter6.pas'
{chapter6.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 EDIT;
CONST
MAXLINES=1000;
DITTO=255;
CURLINE=PERIOD;
LASTLINE=DOLLAR;
SCAN=47;
BACKSCAN=92;
ACMD=97;
CCMD=99;
DCMD=100;
ECMD=101;
EQCMD=EQUALS;
FCMD=102;
GCMD=103;
ICMD=105;
MCMD=109;
PCMD=112;
QCMD=113;
RCMD=114;
SCMD=115;
WCMD=119;
XCMD=120;
TYPE
STCODE=(ENDDATA,ERR,OK);
BUFTYPE=RECORD
TXT:INTEGER;
MARK:BOOLEAN;
END;
VAR
EDITFID:FILE OF CHARACTER;
BUF:ARRAY[0..MAXLINES]OF BUFTYPE;
RECIN:INTEGER;
RECOUT:INTEGER;
LINE1,LINE2,NLINES,CURLN,LASTLN:INTEGER;
PAT,LIN,SAVEFILE:XSTRING;
CURSAVE,I:INTEGER;
STATUS:STCODE;
MORE:BOOLEAN;
PROCEDURE GETTXT(N:INTEGER;VAR S:XSTRING);
VAR
ch:char;JUNK:BOOLEAN;I:INTEGER;
BEGIN
IF(N=0) THEN
S[1]:=ENDSTR
ELSE BEGIN
i:=0;
SEEK(EDITFID,BUF[N].TXT);
repeat
i:=succ(i);
READ(EDITFID,s[i]);
RECIN:=RECIN+1;
until S[I]=ENDSTR;
END
END;
FUNCTION GETMARK(N:INTEGER):BOOLEAN;
BEGIN
GETMARK:=BUF[N].MARK
END;
PROCEDURE PUTMARK(N:INTEGER;M:BOOLEAN);
BEGIN
BUF[N].MARK:=M
END;
FUNCTION DOPRINT(N1,N2:INTEGER):STCODE;
VAR
I:INTEGER;
LINE:XSTRING;
BEGIN
IF(N1<=0)THEN
DOPRINT:=ERR
ELSE BEGIN
FOR I:=N1 TO N2 DO BEGIN
GETTXT(I,LINE);
PUTSTR(LINE,STDOUT)
END;
CURLN:=N2;
DOPRINT:=OK
END
END;
FUNCTION DEFAULT(DEF1,DEF2:INTEGER;
VAR STATUS:STCODE):STCODE;
BEGIN
IF(NLINES=0)THEN BEGIN
LINE1:=DEF1;
LINE2:=DEF2
END;
IF(LINE1 > LINE2)OR(LINE1 <=0)THEN
STATUS:=ERR
ELSE
STATUS:=OK;
DEFAULT:=STATUS
END;
FUNCTION PREVLN(N:INTEGER):INTEGER;
BEGIN
IF(N<=0)THEN
PREVLN:=LASTLN
ELSE
PREVLN:=N-1
END;
FUNCTION NEXTLN(N:INTEGER):INTEGER;
BEGIN
IF(N>=LASTLN)THEN
NEXTLN:=0
ELSE
NEXTLN:=N+1
END;
FUNCTION PATSCAN(WAY:CHARACTER;VAR N:INTEGER):STCODE;
VAR
DONE:BOOLEAN;
LINE:XSTRING;
BEGIN
N:=CURLN;
PATSCAN:=ERR;
DONE:=FALSE;
REPEAT
IF(WAY=SCAN)THEN
N:=NEXTLN(N)
ELSE
N:=PREVLN(N);
GETTXT(N,LINE);
IF(MATCH(LINE,PAT))THEN BEGIN
PATSCAN:=OK;
DONE:=TRUE
END
UNTIL(N=CURLN)OR(DONE)
END;
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;
FUNCTION OPTPAT(VAR LIN:XSTRING;VAR I:INTEGER):STCODE;
BEGIN
IF(LIN[I]=ENDSTR)THEN
I:=0
ELSE IF(LIN[I+1]=ENDSTR)THEN
I:=0
ELSE IF(LIN[I+1]=LIN[I])THEN
I:=I+1
ELSE
I:=MAKEPAT(LIN,I+1,LIN[I],PAT);
IF(PAT[1]=ENDSTR)THEN
I:=0;
IF(I=0)THEN BEGIN
PAT[1]:=ENDSTR;
OPTPAT:=ERR
END
ELSE
OPTPAT:=OK
END;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK)OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETNUM(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
VAR STATUS:STCODE):STCODE;
BEGIN
STATUS:=OK;
SKIPBL(LIN,I);
IF(ISDIGIT(LIN[I]))THEN BEGIN
NUM:=CTOI(LIN,I);
I:=I-1
END
ELSE IF(LIN[I]=CURLINE)THEN
NUM:=CURLN
ELSE IF(LIN[I]=LASTLINE)THEN
NUM:=LASTLN
ELSE IF(LIN[I]=SCAN)OR(LIN[I]=BACKSCAN)THEN BEGIN
IF(OPTPAT(LIN,I)=ERR)THEN
STATUS:=ERR
ELSE
STATUS:=PATSCAN(LIN[I],NUM)
END
ELSE
STATUS:=ENDDATA;
IF(STATUS=OK)THEN
I:=I+1;
GETNUM:=STATUS
END;
FUNCTION GETONE(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
VAR STATUS:STCODE):STCODE;
VAR
ISTART,MUL,PNUM:INTEGER;
BEGIN
ISTART:=I;
NUM:=0;
IF(GETNUM(LIN,I,NUM,STATUS)=OK)THEN
REPEAT
SKIPBL(LIN,I);
IF(LIN[I]<>PLUS)AND(LIN[I]<>MINUS)THEN
STATUS:=ENDDATA
ELSE BEGIN
IF(LIN[I]=PLUS)THEN
MUL:=+1
ELSE
MUL:=-1;
I:=I+1;
IF(GETNUM(LIN,I,PNUM,STATUS)=OK)THEN
NUM:=NUM+MUL*PNUM;
IF(STATUS=ENDDATA)THEN
STATUS:=ERR
END
UNTIL(STATUS<>OK);
IF(NUM<0)OR(NUM > LASTLN)THEN
STATUS:=ERR;
IF(STATUS<>ERR)THEN BEGIN
IF(I<=ISTART)THEN
STATUS:=ENDDATA
ELSE
STATUS:=OK
END;
GETONE:=STATUS
END;
FUNCTION GETLIST(VAR LIN:XSTRING;VAR I:INTEGER;
VAR STATUS:STCODE):STCODE;
VAR
NUM:INTEGER;
DONE:BOOLEAN;
BEGIN
LINE2:=0;
NLINES:=0;
DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK);
WHILE(NOT DONE)DO BEGIN
LINE1:=LINE2;
LINE2:=NUM;
NLINES:=NLINES+1;
IF(LIN[I]=SEMICOL)THEN
CURLN:=NUM;
IF(LIN[I]=COMMA)OR(LIN[I]=SEMICOL)THEN BEGIN
I:=I+1;
DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK)
END
ELSE
DONE:=TRUE
END;
NLINES:=MIN(NLINES,2);
IF(NLINES=0)THEN
LINE2:=CURLN;
IF(NLINES<=1)THEN
LINE1:=LINE2;
IF(STATUS<>ERR)THEN
STATUS:=OK;
GETLIST:=STATUS
END;
PROCEDURE REVERSE(N1,N2:INTEGER);
VAR
TEMP:BUFTYPE;
BEGIN
WHILE(N1<N2)DO BEGIN
TEMP:=BUF[N1];
BUF[N1]:=BUF[N2];
BUF[N2]:=TEMP;
N1:=N1+1;
N2:=N2-1
END
END;
PROCEDURE BLKMOVE(N1,N2,N3:INTEGER);
BEGIN
IF(N3<N1-1)THEN BEGIN
REVERSE(N3+1,N1-1);
REVERSE(N1,N2);
REVERSE(N3+1,N2)
END
ELSE IF(N3>N2)THEN BEGIN
REVERSE(N1,N2);
REVERSE(N2+1,N3);
REVERSE(N1,N3)
END
END;
FUNCTION MOVE(LINE3:INTEGER):STCODE;
BEGIN
IF(LINE1<=0)OR((LINE3>=LINE1)AND(LINE3<LINE2))THEN
MOVE:=ERR
ELSE BEGIN
BLKMOVE(LINE1,LINE2,LINE3);
IF(LINE3>LINE1)THEN
CURLN:=LINE3
ELSE
CURLN:=LINE3+(LINE2-LINE1+1);
MOVE:=OK
END
END;
FUNCTION LNDELETE(N1,N2:INTEGER;VAR STATUS:STCODE):
STCODE;
BEGIN
IF(N1<=0)THEN
STATUS:=ERR
ELSE BEGIN
BLKMOVE(N1,N2,LASTLN);
LASTLN:=LASTLN-(N2-N1+1);
CURLN:=PREVLN(N1);
STATUS:=OK
END;
LNDELETE:=STATUS
END;
FUNCTION CKP(VAR LIN:XSTRING;I:INTEGER;
VAR PFLAG:BOOLEAN;VAR STATUS:STCODE):STCODE;
BEGIN
SKIPBL(LIN,I);
IF(LIN[I]=PCMD)THEN BEGIN
I:=I+1;
PFLAG:=TRUE
END
ELSE
PFLAG:=FALSE;
IF(LIN[I]=NEWLINE)THEN
STATUS:=OK
ELSE
STATUS:=ERR;
CKP:=STATUS
END;
FUNCTION PUTTXT(VAR LIN:XSTRING):STCODE;
VAR I:INTEGER;
BEGIN
PUTTXT:=ERR;
IF(LASTLN<MAXLINES) THEN BEGIN
i:=0;
seek(editfid,recout);
lastln:=lastln+1;
buf[lastln].txt:=recout;
repeat
i:=succ(i);
WRITE(EDITFID,lin[i]);
recout:=recout+1
until lin[i]=ENDSTR;
write(editfid,lin[i]);
PUTMARK(LASTLN,FALSE);
BLKMOVE(LASTLN,LASTLN,CURLN);
CURLN:=CURLN+1;
PUTTXT:=OK
END
END;
PROCEDURE SETBUF;
BEGIN
(*$I-*)
ASSIGN(EDITFID,'EDTEMP');
RESET(EDITFID);
IF (IORESULT<>0) THEN REWRITE(EDITFID);
(*$I+*)
RECOUT:=0;
RECIN:=0;
CURLN:=0;
LASTLN:=0
END;
PROCEDURE CLRBUF;
BEGIN
CLOSE(EDITFID);ERASE(EDITFID)
END;
FUNCTION APPEND(LINE:INTEGER;GLOB:BOOLEAN):STCODE;
VAR
EINLINE:XSTRING;
STAT:STCODE;
DONE:BOOLEAN;
BEGIN
IF(GLOB)THEN
STAT:=ERR
ELSE BEGIN
CURLN:=LINE;
STAT:=OK;
DONE:=FALSE;
WHILE(NOT DONE)AND(STAT=OK)DO
IF(NOT GETLINE(EINLINE,STDIN,MAXSTR))THEN
STAT:=ENDDATA
ELSE IF(EINLINE[1]=PERIOD)
AND(EINLINE[2]=NEWLINE)THEN
DONE:=TRUE
ELSE IF(PUTTXT(EINLINE)=ERR)THEN
STAT:=ERR
END;
APPEND:=STAT
END;
FUNCTION DOWRITE(N1,N2:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
I:INTEGER;
FD: FILEDESC;
LINE: XSTRING;
BEGIN
FD:=CREATE(FIL,IOWRITE);
IF(FD=IOERROR)THEN
DOWRITE:=ERR
ELSE BEGIN
FOR I:=N1 TO N2 DO BEGIN
GETTXT(I,LINE);
PUTSTR(LINE,FD)
END;
XCLOSE(FD);
PUTDEC(N2-N1+1,1);
PUTC(NEWLINE);
DOWRITE:=OK
END
END;
FUNCTION DOREAD(N:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
COUNT:INTEGER;
T:BOOLEAN;
STAT:STCODE;
FD:FILEDESC;
EINLINE:XSTRING;
BEGIN
FD:=OPEN(FIL,IOREAD);
IF(FD=IOERROR)THEN
STAT:=ERR
ELSE BEGIN
CURLN:=N;
STAT:=OK;
COUNT:=0;
REPEAT
T:=GETLINE(EINLINE,FD,MAXSTR);
IF(T)THEN BEGIN
STAT:=PUTTXT(EINLINE);
IF(STAT<>ERR)THEN
COUNT:=COUNT+1
END
UNTIL(STAT<>OK)OR(T=FALSE);
XCLOSE(FD);
PUTDEC(COUNT,1);
PUTC(NEWLINE)
END;
DOREAD:=STAT
END;
FUNCTION GETFN(VAR LIN:XSTRING;VAR I:INTEGER;
VAR FIL:XSTRING):STCODE;
VAR
K:INTEGER;
STAT:STCODE;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:
XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I]IN [BLANK,TAB,NEWLINE])DO
I:=I+1;
J:=1;
WHILE(NOT(S[I]IN [ENDSTR,BLANK,TAB,
NEWLINE]))DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR)THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
BEGIN(*GETFN*)
STAT:=ERR;
IF(LIN[I+1]=BLANK)THEN BEGIN
K:=GETWORD(LIN,I+2,FIL);
IF(K>0)THEN
IF(LIN[K]=NEWLINE)THEN
STAT:=OK
END
ELSE IF(LIN[I+1]=NEWLINE)
AND(SAVEFILE[1]<>ENDSTR)THEN BEGIN
SCOPY(SAVEFILE,1,FIL,1);
STAT:=OK;
END;
IF(STAT=OK)AND(SAVEFILE[1]=ENDSTR)THEN
SCOPY(FIL,1,SAVEFILE,1);
GETFN:=STAT
END;
PROCEDURE CATSUB(VAR LIN:XSTRING;S1,S2: INTEGER;
VAR SUB: XSTRING;VAR NEW:XSTRING;
VAR K:INTEGER;MAXNEW:INTEGER);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE(SUB[I]<>ENDSTR)DO BEGIN
IF(SUB[I]=DITTO)THEN
FOR J:=S1 TO S2-1 DO
JUNK:=ADDSTR(LIN[J],NEW,K,MAXNEW)
ELSE
JUNK:=ADDSTR(SUB[I],NEW,K,MAXNEW);
I:=I+1
END
END;
FUNCTION SUBST( VAR SUB:XSTRING;GFLAG,GLOB:BOOLEAN):STCODE;
VAR
NEW,OLD:XSTRING;
J,K,LASTM,LINE,M:INTEGER;
STAT:STCODE;
DONE,SUBBED,JUNK:BOOLEAN;
BEGIN
IF(GLOB)THEN
STAT:=OK
ELSE
STAT:=ERR;
DONE:=(LINE1<=0);
LINE:=LINE1;
WHILE(NOT DONE)AND(LINE<=LINE2)DO BEGIN
J:=1;
SUBBED:=FALSE;
GETTXT(LINE,OLD);
LASTM:=0;
K:=1;
WHILE(OLD[K]<>ENDSTR)DO BEGIN
IF(GFLAG)OR(NOT SUBBED)THEN
M:=AMATCH(OLD,K,PAT,1)
ELSE
M:=0;
IF(M>0)AND(LASTM<>M)THEN BEGIN
SUBBED:=TRUE;
CATSUB(OLD,K,M,SUB,NEW,J,MAXSTR);
LASTM:=M
END;
IF(M=0)OR(M=K)THEN BEGIN
JUNK:=ADDSTR(OLD[K],NEW,J,MAXSTR);
K:=K+1
END
ELSE
K:=M
END;
IF(SUBBED)THEN BEGIN
IF(NOT ADDSTR(ENDSTR,NEW,J,MAXSTR))THEN BEGIN
STAT:=ERR;
DONE:=TRUE
END
ELSE BEGIN
STAT:=LNDELETE(LINE,LINE,STATUS);
STAT:=PUTTXT(NEW);
LINE2:=LINE2+CURLN-LINE;
LINE:=CURLN;
IF(STAT=ERR)THEN
DONE:=TRUE
ELSE
STAT:=OK
END
END;
LINE:=LINE+1
END;
SUBST:=STAT
END;
FUNCTION MAKESUB(VAR ARG:XSTRING;FROM:INTEGER;
DELIM:CHARACTER;VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE(ARG[I]<>DELIM)AND(ARG[I]<>ENDSTR)DO BEGIN
IF(ARG[I]=ORD('&'))THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF(ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT))THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;
FUNCTION GETRHS(VAR LIN:XSTRING;VAR I:INTEGER;
VAR SUB:XSTRING;VAR GFLAG:BOOLEAN):STCODE;
BEGIN
GETRHS:=OK;
IF(LIN[I]=ENDSTR)THEN
GETRHS:=ERR
ELSE IF(LIN[I+1]=ENDSTR)THEN
GETRHS:=ERR
ELSE BEGIN
I:=MAKESUB(LIN,I+1,LIN[I],SUB);
IF(I=0)THEN
GETRHS:=ERR
ELSE IF(LIN[I+1]=ORD('G'))THEN BEGIN
I:=I+1;
GFLAG:=TRUE
END
ELSE
GFLAG:=FALSE
END
END;
FUNCTION DOCMD(VAR LIN:XSTRING;VAR I:INTEGER;
GLOB:BOOLEAN;VAR STATUS:STCODE):STCODE;
VAR
FIL,SUB:XSTRING;
LINE3:INTEGER;
GFLAG,PFLAG:BOOLEAN;
BEGIN
PFLAG:=FALSE;
STATUS:=ERR;
IF(LIN[I]=PCMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=DOPRINT(LINE1,LINE2)
END
ELSE IF(LIN[I]=NEWLINE)THEN BEGIN
IF(NLINES=0)THEN
LINE2:=NEXTLN(CURLN);
STATUS:=DOPRINT(LINE2,LINE2)
END
ELSE IF(LIN[I]=QCMD)THEN BEGIN
IF( LIN[I+1]=NEWLINE)AND(NLINES=0)AND(NOT GLOB)THEN
STATUS:=ENDDATA
END
ELSE IF(LIN[I]=ACMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
STATUS:=APPEND(LINE2,GLOB)
END
ELSE IF(LIN[I]=CCMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
STATUS:=APPEND(PREVLN(LINE1),GLOB)
END
ELSE IF(LIN[I]=DCMD)THEN BEGIN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
IF(NEXTLN(CURLN)<>0)THEN
CURLN:=NEXTLN(CURLN)
END
ELSE IF(LIN[I]=ICMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN BEGIN
IF(LINE2=0)THEN
STATUS:=APPEND(0,GLOB)
ELSE
STATUS:=APPEND(PREVLN(LINE2),GLOB)
END
END
ELSE IF(LIN[I]=EQCMD)THEN BEGIN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN BEGIN
PUTDEC(LINE2,1);
PUTC(NEWLINE)
END
END
ELSE IF(LIN[I]=MCMD)THEN BEGIN
I:=I+1;
IF(GETONE(LIN,I,LINE3,STATUS)=ENDDATA)THEN
STATUS:=ERR;
IF(STATUS =OK)THEN
IF(CKP(LIN,I,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=MOVE(LINE3)
END
ELSE IF(LIN[I]=SCMD)THEN BEGIN
I:=I+1;
IF(OPTPAT(LIN,I)=OK)THEN
IF(GETRHS(LIN,I,SUB,GFLAG)=OK)THEN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=SUBST(SUB,GFLAG,GLOB)
END
ELSE IF(LIN[I]=ECMD)THEN BEGIN
IF(NLINES =0)THEN
IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
SCOPY(FIL,1,SAVEFILE,1);
CLRBUF;
SETBUF;
STATUS:=DOREAD(0,FIL)
END
END
ELSE IF(LIN[I]=FCMD)THEN BEGIN
IF(NLINES =0)THEN
IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
SCOPY(FIL,1,SAVEFILE,1);
PUTSTR(SAVEFILE,STDOUT);
PUTC(NEWLINE);
STATUS:=OK
END
END
ELSE IF(LIN[I]=RCMD)THEN BEGIN
IF(GETFN(LIN,I,FIL)=OK)THEN
STATUS:=DOREAD(LINE2,FIL)
END
ELSE IF(LIN[I]=WCMD)THEN BEGIN
IF(GETFN(LIN,I,FIL)=OK)THEN
IF(DEFAULT(1,LASTLN,STATUS)=OK)THEN
STATUS:=DOWRITE(LINE1,LINE2,FIL)
END;
IF(STATUS =OK)AND(PFLAG)THEN
STATUS:=DOPRINT(CURLN,CURLN);
DOCMD:=STATUS
END;(*DOCMD*)
FUNCTION CKGLOB(VAR LIN: XSTRING;VAR I:INTEGER;
VAR STATUS:STCODE): STCODE;
VAR
N:INTEGER;
GFLAG:BOOLEAN;
TEMP: XSTRING;
BEGIN
IF(LIN[I]<>GCMD)AND(LIN[I]<>XCMD)THEN
STATUS:=ENDDATA
ELSE BEGIN
GFLAG:=(LIN[I]=GCMD);
I:=I+1;
IF(OPTPAT(LIN,I)=ERR)THEN
STATUS:=ERR
ELSE IF( DEFAULT(1,LASTLN,STATUS)<>ERR)THEN BEGIN
I:=I+1;
FOR N:=LINE1 TO LINE2 DO BEGIN
GETTXT(N,TEMP);
PUTMARK(N,(MATCH(TEMP,PAT)=GFLAG))
END;
FOR N:=1 TO LINE1-1 DO
PUTMARK(N,FALSE);
FOR N:=LINE2+1 TO LASTLN DO
PUTMARK(N,FALSE);
STATUS:=OK
END
END;
CKGLOB:=STATUS
END;
FUNCTION DOGLOB(VAR LIN:XSTRING;VAR I,CURSAVE:INTEGER;
VAR STATUS: STCODE):STCODE;
VAR
COUNT,ISTART,N: INTEGER;
BEGIN
STATUS:=OK;
COUNT:=0;
N:=LINE1;
ISTART:=I;
REPEAT
IF(GETMARK(N))THEN BEGIN
PUTMARK(N,FALSE);
CURLN:=N;
CURSAVE:=CURLN;
I:=ISTART;
IF(DOCMD(LIN,I,TRUE,STATUS)=OK)THEN
COUNT:=0
END
ELSE BEGIN
N:=NEXTLN(N);
COUNT:=COUNT + 1
END
UNTIL(COUNT > LASTLN)OR(STATUS <> OK);
DOGLOB:=STATUS
END;
BEGIN
SETBUF;
PAT[1]:=ENDSTR;
SAVEFILE[1]:=ENDSTR;
IF(GETARG(2,SAVEFILE,MAXSTR))THEN
IF(DOREAD(0,SAVEFILE)=ERR)THEN
WRITELN('?');
MORE:=GETLINE(LIN,STDIN,MAXSTR);
WHILE(MORE)DO BEGIN
I:=1;
CURSAVE:=CURLN;
IF(GETLIST(LIN,I,STATUS)=OK)THEN BEGIN
IF(CKGLOB(LIN,I,STATUS)=OK)THEN
STATUS:=DOGLOB(LIN,I,CURSAVE,STATUS)
ELSE IF(STATUS<>ERR)THEN
STATUS:=DOCMD(LIN,I,FALSE,STATUS)
END;
IF(STATUS=ERR)THEN BEGIN
WRITELN('?');
CURLN:=MIN(CURSAVE,LASTLN)
END
ELSE IF(STATUS=ENDDATA)THEN
MORE:=FALSE;
IF(MORE)THEN
MORE:=GETLINE(LIN,STDIN,MAXSTR)
END;
CLRBUF
END;
SHAR_EOF
if test 16451 -ne "`wc -c < 'chapter6.pas'`"
then
echo shar: error transmitting "'chapter6.pas'" '(should have been 16451 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0reintom@rocky2.UUCP (07/16/86)
#! /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:
# chapter7.pas
# chapter8.pas
# fprims.pas
# initcmd.pas
# shell.pas
# This archive created: Tue Jul 15 11:45:47 1986
export PATH; PATH=/bin:$PATH
if test -f 'chapter7.pas'
then
echo shar: will not over-write existing file "'chapter7.pas'"
else
cat << \SHAR_EOF > 'chapter7.pas'
{chapter7.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 FORMAT;
CONST
CMD=PERIOD;
PAGENUM=SHARP;
PAGEWIDTH=60;
PAGELEN=66;
HUGE=10000;
TYPE
CMDTYPE=(BP,BR,CE,FI,FO,HE,IND,LS,NF,PL,
RM,SP,TI,UL,UNKNOWN);
VAR
CURPAGE,NEWPAGE,LINENO:INTEGER;
PLVAL,M1VAL,M2VAL,M3VAL,M4VAL:INTEGER;
BOTTOM:INTEGER;
HEADER,FOOTER:XSTRING;
FILL:BOOLEAN;
LSVAL,SPVAL,INVAL,RMVAL,TIVAL,CEVAL,ULVAL:INTEGER;
OUTP,OUTW,OUTWDS:INTEGER;
OUTBUF:XSTRING;
DIR:0..1;
INBUF:XSTRING;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK) OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETVAL(VAR BUF:XSTRING;VAR ARGTYPE:INTEGER):INTEGER;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
ARGTYPE:=BUF[I];
IF(ARGTYPE=PLUS) OR (ARGTYPE=MINUS) THEN
I:=I+1;
GETVAL:=CTOI(BUF,I)
END;
PROCEDURE SETPARAM(VAR PARAM:INTEGER;VAL,ARGTYPE,DEFVAL,MINVAL,MAXVAL:
INTEGER);
BEGIN
IF(ARGTYPE=NEWLINE)THEN
PARAM:=DEFVAL
ELSE IF (ARGTYPE=PLUS)THEN
PARAM:=PARAM+VAL
ELSE IF(ARGTYPE=MINUS) THEN
PARAM:=PARAM-VAL
ELSE PARAM:=VAL;
PARAM:=MIN(PARAM,MAXVAL);
PARAM:=MAX(PARAM,MINVAL)
END;
PROCEDURE SKIP(N:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO N DO
PUTC(NEWLINE)
END;
PROCEDURE PUTTL(VAR BUF:XSTRING;PAGENO:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO XLENGTH(BUF) DO
IF(BUF[I]=PAGENUM) THEN
PUTDEC(PAGENO,1)
ELSE
PUTC(BUF[I])
END;
PROCEDURE PUTFOOT;
BEGIN
SKIP(M3VAL);
IF(M4VAL>0) THEN BEGIN
PUTTL(FOOTER,CURPAGE);
SKIP(M4VAL-1)
END
END;
PROCEDURE PUTHEAD;
BEGIN
CURPAGE:=NEWPAGE;
NEWPAGE:=NEWPAGE+1;
IF(M1VAL>0)THEN BEGIN
SKIP(M1VAL-1);
PUTTL(HEADER,CURPAGE)
END;
SKIP(M2VAL);
LINENO:=M1VAL+M2VAL+1
END;
PROCEDURE PUT(VAR BUF:XSTRING);
VAR
I:INTEGER;
BEGIN
IF(LINENO<=0) OR(LINENO>BOTTOM) THEN
PUTHEAD;
FOR I:=1 TO INVAL+TIVAL DO
PUTC(BLANK);
TIVAL:=0;
PUTSTR(BUF,STDOUT);
SKIP(MIN(LSVAL-1,BOTTOM-LINENO));
LINENO:=LINENO+LSVAL;
IF(LINENO>BOTTOM)THEN PUTFOOT
END;
PROCEDURE BREAK;
BEGIN
IF(OUTP>0) THEN BEGIN
OUTBUF[OUTP]:=NEWLINE;
OUTBUF[OUTP+1]:=ENDSTR;
PUT(OUTBUF)
END;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
PROCEDURE LEADBL(VAR BUF:XSTRING);
VAR I,J:INTEGER;
BEGIN
BREAK;
I:=1;
WHILE(BUF[I]=BLANK) DO
I:=I+1;
IF(BUF[I]<>NEWLINE) THEN
TIVAL:=TIVAL+I-1;
FOR J:=I TO XLENGTH(BUF)+1 DO
BUF[J-I+1]:=BUF[J]
END;
PROCEDURE GETTL(VAR BUF,TTL:XSTRING);
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
IF(BUF[I]=SQUOTE) OR(BUF[I]=DQUOTE)THEN
I:=I+1;
SCOPY(BUF,I,TTL,1)
END;
PROCEDURE SPACE(N:INTEGER);
BEGIN
BREAK;
IF (LINENO<=BOTTOM) THEN BEGIN
IF(LINENO<=0)THEN
PUTHEAD;
SKIP(MIN(N,BOTTOM+1-LINENO));
LINENO:=LINENO+N;
IF(LINENO>BOTTOM) THEN
PUTFOOT
END
END;
PROCEDURE PAGE;
BEGIN
BREAK;
IF(LINENO>0) AND (LINENO<=BOTTOM) THEN BEGIN
SKIP(BOTTOM+1-LINENO);putfoot
END;
LINENO:=0
END;
FUNCTION WIDTH(VAR BUF:XSTRING):INTEGER;
VAR
I,W:INTEGER;
BEGIN
W:=0;
I:=1;
WHILE(BUF[I]<>ENDSTR) DO BEGIN
IF (BUF[I] = BACKSPACE) THEN
W:=W-1
ELSE IF (BUF[I]<>NEWLINE) THEN
W:=W+1;I:=I+1
END;
WIDTH:=W
END;
PROCEDURE SPREAD(VAR BUF:XSTRING;
OUTP,NEXTRA,OUTWDS:INTEGER);
VAR
I,J,NB,NHOLES:INTEGER;
BEGIN
IF(NEXTRA>0) AND (OUTWDS>1) THEN BEGIN
DIR:=1-DIR;
NHOLES:=OUTWDS-1;
I:=OUTP-1;
J:=MIN(MAXSTR-2,I+NEXTRA);
WHILE(I<J) DO BEGIN
BUF[J]:=BUF[I];
IF(BUF[I]=BLANK) THEN BEGIN
IF(DIR=0) THEN
NB:=(NEXTRA-1) DIV NHOLES +1
ELSE NB:=NEXTRA DIV NHOLES;
NEXTRA:=NEXTRA - NB;
NHOLES:=NHOLES-1;
WHILE(NB>0) DO BEGIN
J:=J-1;
BUF[J]:=BLANK;
NB:=NB-1
END
END;
I:=I-1;
J:=J-1
END
END
END;
PROCEDURE PUTWORD(VAR WORDBUF:XSTRING);
VAR
LAST,LLVAL,NEXTRA,W:INTEGER;
BEGIN
W:=WIDTH(WORDBUF);
LAST:=XLENGTH(WORDBUF)+OUTP+1;
LLVAL:=RMVAL-TIVAL-INVAL;
IF(OUTP>0)
AND ((OUTW+W>LLVAL) OR (LAST >=MAXSTR)) THEN BEGIN
LAST:=LAST-OUTP;
NEXTRA:=LLVAL-OUTW+1;
IF(NEXTRA >0) AND(OUTWDS>1) THEN BEGIN
SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS);
OUTP:=OUTP+NEXTRA
END;
BREAK
END;
SCOPY(WORDBUF,1,OUTBUF,OUTP+1);
OUTP:=LAST;
OUTBUF[OUTP]:=BLANK;
OUTW:=OUTW+W+1;
OUTWDS:=OUTWDS+1
END;
PROCEDURE CENTER(VAR BUF:XSTRING);
BEGIN
TIVAL:=MAX((RMVAL+TIVAL-WIDTH(BUF)) DIV 2,0)
END;
PROCEDURE UNDERLN (VAR BUF:XSTRING;SIZE:INTEGER);
VAR
I,J:INTEGER;
TBUF:XSTRING;
BEGIN
J:=1;
I:=1;
WHILE(BUF[I]<>NEWLINE) AND (J<SIZE-1)DO BEGIN
IF(ISALPHANUM(BUF[I])) THEN BEGIN
TBUF[J]:=UNDERLINE;
TBUF[J+1]:=BACKSPACE;
J:=J+2
END;
TBUF[J]:=BUF[I];
J:=J+1;
I:=I+1
END;
TBUF[J]:=NEWLINE;
TBUF[J+1]:=ENDSTR;
SCOPY(TBUF,1,BUF,1)
END;
PROCEDURE TEXT(VAR INBUF:XSTRING);
VAR
WORDBUF:XSTRING;
I:INTEGER;
BEGIN
IF(INBUF[1]=BLANK) OR (INBUF[1]=NEWLINE) THEN
LEADBL(INBUF);
IF(ULVAL>0) THEN BEGIN
UNDERLN(INBUF,MAXSTR);
ULVAL:=ULVAL-1
END;
IF(CEVAL>0)THEN BEGIN
CENTER(INBUF);
PUT(INBUF);
CEVAL:=CEVAL-1
END
ELSE IF (INBUF[1]=NEWLINE)THEN
PUT(INBUF)
ELSE IF(NOT FILL) THEN
PUT(INBUF)
ELSE BEGIN
I:=1;
REPEAT
I:=GETWORD(INBUF,I,WORDBUF);
IF(I>0)THEN
PUTWORD(WORDBUF)
UNTIL(I=0)
END
END;
PROCEDURE INITFMT;
BEGIN
FILL:=TRUE;
DIR:=0;
INVAL:=0;
RMVAL:=PAGEWIDTH;
TIVAL:=0;
LSVAL:=1;
SPVAL:=0;
CEVAL:=0;
ULVAL:=0;
LINENO:=0;
CURPAGE:=0;
NEWPAGE:=1;
PLVAL:=PAGELEN;
M1VAL:=3;M2VAL:=2;M3VAL:=2;M4VAL:=3;
BOTTOM:=PLVAL-M3VAL-M4VAL;
HEADER[1]:=NEWLINE;
HEADER[2]:=ENDSTR;
FOOTER[1]:=NEWLINE;
FOOTER[2]:=ENDSTR;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETCMD(VAR BUF:XSTRING):CMDTYPE;
VAR
CMD:PACKED ARRAY[1..2] OF CHAR;
BEGIN
CMD[1]:=CHR(BUF[2]);
CMD[2]:=CHR(BUF[3]);
IF(CMD='fi')THEN GETCMD:=FI
ELSE IF (CMD='nf')THEN GETCMD:=NF
ELSE IF (CMD='br')THEN GETCMD:=BR
ELSE IF (CMD='ls')THEN GETCMD:=LS
ELSE IF (CMD='bp')THEN GETCMD:=BP
ELSE IF (CMD='sp')THEN GETCMD:=SP
ELSE IF (CMD='in')THEN GETCMD:=IND
ELSE IF (CMD='rm')THEN GETCMD:=RM
ELSE IF (CMD='ce')THEN GETCMD:=CE
ELSE IF (CMD='ti')THEN GETCMD:=TI
ELSE IF (CMD='ul')THEN GETCMD:=UL
ELSE IF (CMD='he') THEN GETCMD:=HE
ELSE IF (CMD='fo') THEN GETCMD:=FO
ELSE IF (CMD='pl') THEN GETCMD:=PL
ELSE GETCMD:=UNKNOWN
END;
PROCEDURE COMMAND(VAR BUF:XSTRING);
VAR CMD:CMDTYPE;
ARGTYPE,SPVAL,VAL:INTEGER;
BEGIN
CMD:=GETCMD(BUF);
IF(CMD<>UNKNOWN)THEN
VAL:=GETVAL(BUF,ARGTYPE);
CASE CMD OF
FI:BEGIN
BREAK;
FILL:=TRUE END;
NF:BEGIN BREAK;
FILL:=FALSE END;
BR:BREAK;
LS:SETPARAM(LSVAL,VAL,ARGTYPE,1,1,HUGE);
CE:BEGIN BREAK;
SETPARAM(CEVAL,VAL,ARGTYPE,1,0,HUGE) END;
UL:SETPARAM(ULVAL,VAL,ARGTYPE,1,0,HUGE);
HE:GETTL(BUF,HEADER);
FO:GETTL(BUF,FOOTER);
BP:BEGIN PAGE;
SETPARAM(CURPAGE,VAL,ARGTYPE,CURPAGE+1,-HUGE,HUGE);
NEWPAGE:=CURPAGE END;
SP:BEGIN
SETPARAM(SPVAL,VAL,ARGTYPE,1,0,HUGE);
space(spval)
END;
IND:SETPARAM(INVAL,VAL,ARGTYPE,0,0,RMVAL-1);
RM:SETPARAM(INVAL,VAL,ARGTYPE,PAGEWIDTH,
INVAL+TIVAL+1,HUGE);
TI:BEGIN BREAK;
SETPARAM(TIVAL,VAL,ARGTYPE,0,-HUGE,RMVAL) END;
PL:BEGIN
SETPARAM(PLVAL,VAL,ARGTYPE,PAGELEN,
M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE);
BOTTOM:=PLVAL-M3VAL-M4VAL END;
UNKNOWN:
END
END;
BEGIN
INITFMT;
WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO
IF(INBUF[1]=CMD) THEN
COMMAND(INBUF)
ELSE
TEXT(INBUF);
PAGE
END;
SHAR_EOF
if test 8627 -ne "`wc -c < 'chapter7.pas'`"
then
echo shar: error transmitting "'chapter7.pas'" '(should have been 8627 characters)'
fi
fi # end of overwriting check
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
# End of shell archive
exit 0reintom@rocky2.UUCP (Tom Reingold) (09/19/86)
#! /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:
# chapter5.pas
# chapter6.pas
# chapter7.pas
# This archive created: Thu Sep 18 14:27:33 1986
export PATH; PATH=/bin:$PATH
if test -f 'chapter5.pas'
then
echo shar: will not over-write existing file "'chapter5.pas'"
else
cat << \SHAR_EOF > 'chapter5.pas'
{chapter5.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;
PROCEDURE FIND;
VAR
ARG,LIN,PAT:XSTRING;
FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;
BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
BEGIN
IF(NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:FIND PATTERN');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('FIND:ILLEGAL PATTERN');
WHILE(GETLINE(LIN,STDIN,MAXSTR))DO
IF (MATCH(LIN,PAT))THEN
PUTSTR(LIN,STDOUT)
END;
PROCEDURE CHANGE;
CONST
DITTO=255;
VAR
LIN,PAT,SUB,ARG:XSTRING;
FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;
BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
FUNCTION GETSUB(VAR ARG,SUB:XSTRING):BOOLEAN;
FUNCTION MAKESUB(VAR ARG:XSTRING; FROM:INTEGER;
DELIM:CHARACTER; VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE (ARG[I]<>DELIM) AND (ARG[I]<>ENDSTR) DO BEGIN
IF(ARG[I]=ORD('&')) THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF (ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT)) THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;
BEGIN
GETSUB:=(MAKESUB(ARG,1,ENDSTR,SUB)>0)
END;
PROCEDURE SUBLINE(VAR LIN,PAT,SUB:XSTRING);
VAR
I, LASTM, M:INTEGER;
JUNK:BOOLEAN;
PROCEDURE PUTSUB(VAR LIN:XSTRING; S1,S2:INTEGER;
VAR SUB:XSTRING);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE (SUB[I]<>ENDSTR) DO BEGIN
IF(SUB[I]=DITTO) THEN
FOR J:=S1 TO S2-1 DO
PUTC(LIN[J])
ELSE
PUTC(SUB[I]);
I:=I+1
END
END;
BEGIN
LASTM:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) DO BEGIN
M:=AMATCH(LIN,I,PAT,1);
IF (M>0) AND (LASTM<>M) THEN BEGIN
PUTSUB(LIN,I,M,SUB);
LASTM:=M
END;
IF (M=0) OR (M=I) THEN BEGIN
PUTC(LIN[I]);
I:=I+1
END
ELSE
I:=M
END
END;
BEGIN
IF(NOT GETARG(2,ARG,MAXSTR)) THEN
ERROR('USAGE:CHANGE FROM [TO]');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('CHANGE:ILLEGAL "FROM" PATTERN');
IF (NOT GETARG(3,ARG,MAXSTR)) THEN
ARG[1]:=ENDSTR;
IF(NOT GETSUB(ARG,SUB)) THEN
ERROR('CHANGE:ILLEGAL "TO" STRING');
WHILE (GETLINE(LIN,STDIN,MAXSTR)) DO
SUBLINE(LIN,PAT,SUB)
END;
SHAR_EOF
if test 8365 -ne "`wc -c < 'chapter5.pas'`"
then
echo shar: error transmitting "'chapter5.pas'" '(should have been 8365 characters)'
fi
fi # end of overwriting check
if test -f 'chapter6.pas'
then
echo shar: will not over-write existing file "'chapter6.pas'"
else
cat << \SHAR_EOF > 'chapter6.pas'
{chapter6.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 EDIT;
CONST
MAXLINES=1000;
DITTO=255;
CURLINE=PERIOD;
LASTLINE=DOLLAR;
SCAN=47;
BACKSCAN=92;
ACMD=97;
CCMD=99;
DCMD=100;
ECMD=101;
EQCMD=EQUALS;
FCMD=102;
GCMD=103;
ICMD=105;
MCMD=109;
PCMD=112;
QCMD=113;
RCMD=114;
SCMD=115;
WCMD=119;
XCMD=120;
TYPE
STCODE=(ENDDATA,ERR,OK);
BUFTYPE=RECORD
TXT:INTEGER;
MARK:BOOLEAN;
END;
VAR
EDITFID:FILE OF CHARACTER;
BUF:ARRAY[0..MAXLINES]OF BUFTYPE;
RECIN:INTEGER;
RECOUT:INTEGER;
LINE1,LINE2,NLINES,CURLN,LASTLN:INTEGER;
PAT,LIN,SAVEFILE:XSTRING;
CURSAVE,I:INTEGER;
STATUS:STCODE;
MORE:BOOLEAN;
PROCEDURE GETTXT(N:INTEGER;VAR S:XSTRING);
VAR
ch:char;JUNK:BOOLEAN;I:INTEGER;
BEGIN
IF(N=0) THEN
S[1]:=ENDSTR
ELSE BEGIN
i:=0;
SEEK(EDITFID,BUF[N].TXT);
repeat
i:=succ(i);
READ(EDITFID,s[i]);
RECIN:=RECIN+1;
until S[I]=ENDSTR;
END
END;
FUNCTION GETMARK(N:INTEGER):BOOLEAN;
BEGIN
GETMARK:=BUF[N].MARK
END;
PROCEDURE PUTMARK(N:INTEGER;M:BOOLEAN);
BEGIN
BUF[N].MARK:=M
END;
FUNCTION DOPRINT(N1,N2:INTEGER):STCODE;
VAR
I:INTEGER;
LINE:XSTRING;
BEGIN
IF(N1<=0)THEN
DOPRINT:=ERR
ELSE BEGIN
FOR I:=N1 TO N2 DO BEGIN
GETTXT(I,LINE);
PUTSTR(LINE,STDOUT)
END;
CURLN:=N2;
DOPRINT:=OK
END
END;
FUNCTION DEFAULT(DEF1,DEF2:INTEGER;
VAR STATUS:STCODE):STCODE;
BEGIN
IF(NLINES=0)THEN BEGIN
LINE1:=DEF1;
LINE2:=DEF2
END;
IF(LINE1 > LINE2)OR(LINE1 <=0)THEN
STATUS:=ERR
ELSE
STATUS:=OK;
DEFAULT:=STATUS
END;
FUNCTION PREVLN(N:INTEGER):INTEGER;
BEGIN
IF(N<=0)THEN
PREVLN:=LASTLN
ELSE
PREVLN:=N-1
END;
FUNCTION NEXTLN(N:INTEGER):INTEGER;
BEGIN
IF(N>=LASTLN)THEN
NEXTLN:=0
ELSE
NEXTLN:=N+1
END;
FUNCTION PATSCAN(WAY:CHARACTER;VAR N:INTEGER):STCODE;
VAR
DONE:BOOLEAN;
LINE:XSTRING;
BEGIN
N:=CURLN;
PATSCAN:=ERR;
DONE:=FALSE;
REPEAT
IF(WAY=SCAN)THEN
N:=NEXTLN(N)
ELSE
N:=PREVLN(N);
GETTXT(N,LINE);
IF(MATCH(LINE,PAT))THEN BEGIN
PATSCAN:=OK;
DONE:=TRUE
END
UNTIL(N=CURLN)OR(DONE)
END;
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;
FUNCTION OPTPAT(VAR LIN:XSTRING;VAR I:INTEGER):STCODE;
BEGIN
IF(LIN[I]=ENDSTR)THEN
I:=0
ELSE IF(LIN[I+1]=ENDSTR)THEN
I:=0
ELSE IF(LIN[I+1]=LIN[I])THEN
I:=I+1
ELSE
I:=MAKEPAT(LIN,I+1,LIN[I],PAT);
IF(PAT[1]=ENDSTR)THEN
I:=0;
IF(I=0)THEN BEGIN
PAT[1]:=ENDSTR;
OPTPAT:=ERR
END
ELSE
OPTPAT:=OK
END;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK)OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETNUM(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
VAR STATUS:STCODE):STCODE;
BEGIN
STATUS:=OK;
SKIPBL(LIN,I);
IF(ISDIGIT(LIN[I]))THEN BEGIN
NUM:=CTOI(LIN,I);
I:=I-1
END
ELSE IF(LIN[I]=CURLINE)THEN
NUM:=CURLN
ELSE IF(LIN[I]=LASTLINE)THEN
NUM:=LASTLN
ELSE IF(LIN[I]=SCAN)OR(LIN[I]=BACKSCAN)THEN BEGIN
IF(OPTPAT(LIN,I)=ERR)THEN
STATUS:=ERR
ELSE
STATUS:=PATSCAN(LIN[I],NUM)
END
ELSE
STATUS:=ENDDATA;
IF(STATUS=OK)THEN
I:=I+1;
GETNUM:=STATUS
END;
FUNCTION GETONE(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
VAR STATUS:STCODE):STCODE;
VAR
ISTART,MUL,PNUM:INTEGER;
BEGIN
ISTART:=I;
NUM:=0;
IF(GETNUM(LIN,I,NUM,STATUS)=OK)THEN
REPEAT
SKIPBL(LIN,I);
IF(LIN[I]<>PLUS)AND(LIN[I]<>MINUS)THEN
STATUS:=ENDDATA
ELSE BEGIN
IF(LIN[I]=PLUS)THEN
MUL:=+1
ELSE
MUL:=-1;
I:=I+1;
IF(GETNUM(LIN,I,PNUM,STATUS)=OK)THEN
NUM:=NUM+MUL*PNUM;
IF(STATUS=ENDDATA)THEN
STATUS:=ERR
END
UNTIL(STATUS<>OK);
IF(NUM<0)OR(NUM > LASTLN)THEN
STATUS:=ERR;
IF(STATUS<>ERR)THEN BEGIN
IF(I<=ISTART)THEN
STATUS:=ENDDATA
ELSE
STATUS:=OK
END;
GETONE:=STATUS
END;
FUNCTION GETLIST(VAR LIN:XSTRING;VAR I:INTEGER;
VAR STATUS:STCODE):STCODE;
VAR
NUM:INTEGER;
DONE:BOOLEAN;
BEGIN
LINE2:=0;
NLINES:=0;
DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK);
WHILE(NOT DONE)DO BEGIN
LINE1:=LINE2;
LINE2:=NUM;
NLINES:=NLINES+1;
IF(LIN[I]=SEMICOL)THEN
CURLN:=NUM;
IF(LIN[I]=COMMA)OR(LIN[I]=SEMICOL)THEN BEGIN
I:=I+1;
DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK)
END
ELSE
DONE:=TRUE
END;
NLINES:=MIN(NLINES,2);
IF(NLINES=0)THEN
LINE2:=CURLN;
IF(NLINES<=1)THEN
LINE1:=LINE2;
IF(STATUS<>ERR)THEN
STATUS:=OK;
GETLIST:=STATUS
END;
PROCEDURE REVERSE(N1,N2:INTEGER);
VAR
TEMP:BUFTYPE;
BEGIN
WHILE(N1<N2)DO BEGIN
TEMP:=BUF[N1];
BUF[N1]:=BUF[N2];
BUF[N2]:=TEMP;
N1:=N1+1;
N2:=N2-1
END
END;
PROCEDURE BLKMOVE(N1,N2,N3:INTEGER);
BEGIN
IF(N3<N1-1)THEN BEGIN
REVERSE(N3+1,N1-1);
REVERSE(N1,N2);
REVERSE(N3+1,N2)
END
ELSE IF(N3>N2)THEN BEGIN
REVERSE(N1,N2);
REVERSE(N2+1,N3);
REVERSE(N1,N3)
END
END;
FUNCTION MOVE(LINE3:INTEGER):STCODE;
BEGIN
IF(LINE1<=0)OR((LINE3>=LINE1)AND(LINE3<LINE2))THEN
MOVE:=ERR
ELSE BEGIN
BLKMOVE(LINE1,LINE2,LINE3);
IF(LINE3>LINE1)THEN
CURLN:=LINE3
ELSE
CURLN:=LINE3+(LINE2-LINE1+1);
MOVE:=OK
END
END;
FUNCTION LNDELETE(N1,N2:INTEGER;VAR STATUS:STCODE):
STCODE;
BEGIN
IF(N1<=0)THEN
STATUS:=ERR
ELSE BEGIN
BLKMOVE(N1,N2,LASTLN);
LASTLN:=LASTLN-(N2-N1+1);
CURLN:=PREVLN(N1);
STATUS:=OK
END;
LNDELETE:=STATUS
END;
FUNCTION CKP(VAR LIN:XSTRING;I:INTEGER;
VAR PFLAG:BOOLEAN;VAR STATUS:STCODE):STCODE;
BEGIN
SKIPBL(LIN,I);
IF(LIN[I]=PCMD)THEN BEGIN
I:=I+1;
PFLAG:=TRUE
END
ELSE
PFLAG:=FALSE;
IF(LIN[I]=NEWLINE)THEN
STATUS:=OK
ELSE
STATUS:=ERR;
CKP:=STATUS
END;
FUNCTION PUTTXT(VAR LIN:XSTRING):STCODE;
VAR I:INTEGER;
BEGIN
PUTTXT:=ERR;
IF(LASTLN<MAXLINES) THEN BEGIN
i:=0;
seek(editfid,recout);
lastln:=lastln+1;
buf[lastln].txt:=recout;
repeat
i:=succ(i);
WRITE(EDITFID,lin[i]);
recout:=recout+1
until lin[i]=ENDSTR;
write(editfid,lin[i]);
PUTMARK(LASTLN,FALSE);
BLKMOVE(LASTLN,LASTLN,CURLN);
CURLN:=CURLN+1;
PUTTXT:=OK
END
END;
PROCEDURE SETBUF;
BEGIN
(*$I-*)
ASSIGN(EDITFID,'EDTEMP');
RESET(EDITFID);
IF (IORESULT<>0) THEN REWRITE(EDITFID);
(*$I+*)
RECOUT:=0;
RECIN:=0;
CURLN:=0;
LASTLN:=0
END;
PROCEDURE CLRBUF;
BEGIN
CLOSE(EDITFID);ERASE(EDITFID)
END;
FUNCTION APPEND(LINE:INTEGER;GLOB:BOOLEAN):STCODE;
VAR
EINLINE:XSTRING;
STAT:STCODE;
DONE:BOOLEAN;
BEGIN
IF(GLOB)THEN
STAT:=ERR
ELSE BEGIN
CURLN:=LINE;
STAT:=OK;
DONE:=FALSE;
WHILE(NOT DONE)AND(STAT=OK)DO
IF(NOT GETLINE(EINLINE,STDIN,MAXSTR))THEN
STAT:=ENDDATA
ELSE IF(EINLINE[1]=PERIOD)
AND(EINLINE[2]=NEWLINE)THEN
DONE:=TRUE
ELSE IF(PUTTXT(EINLINE)=ERR)THEN
STAT:=ERR
END;
APPEND:=STAT
END;
FUNCTION DOWRITE(N1,N2:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
I:INTEGER;
FD: FILEDESC;
LINE: XSTRING;
BEGIN
FD:=CREATE(FIL,IOWRITE);
IF(FD=IOERROR)THEN
DOWRITE:=ERR
ELSE BEGIN
FOR I:=N1 TO N2 DO BEGIN
GETTXT(I,LINE);
PUTSTR(LINE,FD)
END;
XCLOSE(FD);
PUTDEC(N2-N1+1,1);
PUTC(NEWLINE);
DOWRITE:=OK
END
END;
FUNCTION DOREAD(N:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
COUNT:INTEGER;
T:BOOLEAN;
STAT:STCODE;
FD:FILEDESC;
EINLINE:XSTRING;
BEGIN
FD:=OPEN(FIL,IOREAD);
IF(FD=IOERROR)THEN
STAT:=ERR
ELSE BEGIN
CURLN:=N;
STAT:=OK;
COUNT:=0;
REPEAT
T:=GETLINE(EINLINE,FD,MAXSTR);
IF(T)THEN BEGIN
STAT:=PUTTXT(EINLINE);
IF(STAT<>ERR)THEN
COUNT:=COUNT+1
END
UNTIL(STAT<>OK)OR(T=FALSE);
XCLOSE(FD);
PUTDEC(COUNT,1);
PUTC(NEWLINE)
END;
DOREAD:=STAT
END;
FUNCTION GETFN(VAR LIN:XSTRING;VAR I:INTEGER;
VAR FIL:XSTRING):STCODE;
VAR
K:INTEGER;
STAT:STCODE;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:
XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I]IN [BLANK,TAB,NEWLINE])DO
I:=I+1;
J:=1;
WHILE(NOT(S[I]IN [ENDSTR,BLANK,TAB,
NEWLINE]))DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR)THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
BEGIN(*GETFN*)
STAT:=ERR;
IF(LIN[I+1]=BLANK)THEN BEGIN
K:=GETWORD(LIN,I+2,FIL);
IF(K>0)THEN
IF(LIN[K]=NEWLINE)THEN
STAT:=OK
END
ELSE IF(LIN[I+1]=NEWLINE)
AND(SAVEFILE[1]<>ENDSTR)THEN BEGIN
SCOPY(SAVEFILE,1,FIL,1);
STAT:=OK;
END;
IF(STAT=OK)AND(SAVEFILE[1]=ENDSTR)THEN
SCOPY(FIL,1,SAVEFILE,1);
GETFN:=STAT
END;
PROCEDURE CATSUB(VAR LIN:XSTRING;S1,S2: INTEGER;
VAR SUB: XSTRING;VAR NEW:XSTRING;
VAR K:INTEGER;MAXNEW:INTEGER);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE(SUB[I]<>ENDSTR)DO BEGIN
IF(SUB[I]=DITTO)THEN
FOR J:=S1 TO S2-1 DO
JUNK:=ADDSTR(LIN[J],NEW,K,MAXNEW)
ELSE
JUNK:=ADDSTR(SUB[I],NEW,K,MAXNEW);
I:=I+1
END
END;
FUNCTION SUBST( VAR SUB:XSTRING;GFLAG,GLOB:BOOLEAN):STCODE;
VAR
NEW,OLD:XSTRING;
J,K,LASTM,LINE,M:INTEGER;
STAT:STCODE;
DONE,SUBBED,JUNK:BOOLEAN;
BEGIN
IF(GLOB)THEN
STAT:=OK
ELSE
STAT:=ERR;
DONE:=(LINE1<=0);
LINE:=LINE1;
WHILE(NOT DONE)AND(LINE<=LINE2)DO BEGIN
J:=1;
SUBBED:=FALSE;
GETTXT(LINE,OLD);
LASTM:=0;
K:=1;
WHILE(OLD[K]<>ENDSTR)DO BEGIN
IF(GFLAG)OR(NOT SUBBED)THEN
M:=AMATCH(OLD,K,PAT,1)
ELSE
M:=0;
IF(M>0)AND(LASTM<>M)THEN BEGIN
SUBBED:=TRUE;
CATSUB(OLD,K,M,SUB,NEW,J,MAXSTR);
LASTM:=M
END;
IF(M=0)OR(M=K)THEN BEGIN
JUNK:=ADDSTR(OLD[K],NEW,J,MAXSTR);
K:=K+1
END
ELSE
K:=M
END;
IF(SUBBED)THEN BEGIN
IF(NOT ADDSTR(ENDSTR,NEW,J,MAXSTR))THEN BEGIN
STAT:=ERR;
DONE:=TRUE
END
ELSE BEGIN
STAT:=LNDELETE(LINE,LINE,STATUS);
STAT:=PUTTXT(NEW);
LINE2:=LINE2+CURLN-LINE;
LINE:=CURLN;
IF(STAT=ERR)THEN
DONE:=TRUE
ELSE
STAT:=OK
END
END;
LINE:=LINE+1
END;
SUBST:=STAT
END;
FUNCTION MAKESUB(VAR ARG:XSTRING;FROM:INTEGER;
DELIM:CHARACTER;VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE(ARG[I]<>DELIM)AND(ARG[I]<>ENDSTR)DO BEGIN
IF(ARG[I]=ORD('&'))THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF(ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT))THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;
FUNCTION GETRHS(VAR LIN:XSTRING;VAR I:INTEGER;
VAR SUB:XSTRING;VAR GFLAG:BOOLEAN):STCODE;
BEGIN
GETRHS:=OK;
IF(LIN[I]=ENDSTR)THEN
GETRHS:=ERR
ELSE IF(LIN[I+1]=ENDSTR)THEN
GETRHS:=ERR
ELSE BEGIN
I:=MAKESUB(LIN,I+1,LIN[I],SUB);
IF(I=0)THEN
GETRHS:=ERR
ELSE IF(LIN[I+1]=ORD('G'))THEN BEGIN
I:=I+1;
GFLAG:=TRUE
END
ELSE
GFLAG:=FALSE
END
END;
FUNCTION DOCMD(VAR LIN:XSTRING;VAR I:INTEGER;
GLOB:BOOLEAN;VAR STATUS:STCODE):STCODE;
VAR
FIL,SUB:XSTRING;
LINE3:INTEGER;
GFLAG,PFLAG:BOOLEAN;
BEGIN
PFLAG:=FALSE;
STATUS:=ERR;
IF(LIN[I]=PCMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=DOPRINT(LINE1,LINE2)
END
ELSE IF(LIN[I]=NEWLINE)THEN BEGIN
IF(NLINES=0)THEN
LINE2:=NEXTLN(CURLN);
STATUS:=DOPRINT(LINE2,LINE2)
END
ELSE IF(LIN[I]=QCMD)THEN BEGIN
IF( LIN[I+1]=NEWLINE)AND(NLINES=0)AND(NOT GLOB)THEN
STATUS:=ENDDATA
END
ELSE IF(LIN[I]=ACMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
STATUS:=APPEND(LINE2,GLOB)
END
ELSE IF(LIN[I]=CCMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
STATUS:=APPEND(PREVLN(LINE1),GLOB)
END
ELSE IF(LIN[I]=DCMD)THEN BEGIN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
IF(NEXTLN(CURLN)<>0)THEN
CURLN:=NEXTLN(CURLN)
END
ELSE IF(LIN[I]=ICMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN BEGIN
IF(LINE2=0)THEN
STATUS:=APPEND(0,GLOB)
ELSE
STATUS:=APPEND(PREVLN(LINE2),GLOB)
END
END
ELSE IF(LIN[I]=EQCMD)THEN BEGIN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN BEGIN
PUTDEC(LINE2,1);
PUTC(NEWLINE)
END
END
ELSE IF(LIN[I]=MCMD)THEN BEGIN
I:=I+1;
IF(GETONE(LIN,I,LINE3,STATUS)=ENDDATA)THEN
STATUS:=ERR;
IF(STATUS =OK)THEN
IF(CKP(LIN,I,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=MOVE(LINE3)
END
ELSE IF(LIN[I]=SCMD)THEN BEGIN
I:=I+1;
IF(OPTPAT(LIN,I)=OK)THEN
IF(GETRHS(LIN,I,SUB,GFLAG)=OK)THEN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=SUBST(SUB,GFLAG,GLOB)
END
ELSE IF(LIN[I]=ECMD)THEN BEGIN
IF(NLINES =0)THEN
IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
SCOPY(FIL,1,SAVEFILE,1);
CLRBUF;
SETBUF;
STATUS:=DOREAD(0,FIL)
END
END
ELSE IF(LIN[I]=FCMD)THEN BEGIN
IF(NLINES =0)THEN
IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
SCOPY(FIL,1,SAVEFILE,1);
PUTSTR(SAVEFILE,STDOUT);
PUTC(NEWLINE);
STATUS:=OK
END
END
ELSE IF(LIN[I]=RCMD)THEN BEGIN
IF(GETFN(LIN,I,FIL)=OK)THEN
STATUS:=DOREAD(LINE2,FIL)
END
ELSE IF(LIN[I]=WCMD)THEN BEGIN
IF(GETFN(LIN,I,FIL)=OK)THEN
IF(DEFAULT(1,LASTLN,STATUS)=OK)THEN
STATUS:=DOWRITE(LINE1,LINE2,FIL)
END;
IF(STATUS =OK)AND(PFLAG)THEN
STATUS:=DOPRINT(CURLN,CURLN);
DOCMD:=STATUS
END;(*DOCMD*)
FUNCTION CKGLOB(VAR LIN: XSTRING;VAR I:INTEGER;
VAR STATUS:STCODE): STCODE;
VAR
N:INTEGER;
GFLAG:BOOLEAN;
TEMP: XSTRING;
BEGIN
IF(LIN[I]<>GCMD)AND(LIN[I]<>XCMD)THEN
STATUS:=ENDDATA
ELSE BEGIN
GFLAG:=(LIN[I]=GCMD);
I:=I+1;
IF(OPTPAT(LIN,I)=ERR)THEN
STATUS:=ERR
ELSE IF( DEFAULT(1,LASTLN,STATUS)<>ERR)THEN BEGIN
I:=I+1;
FOR N:=LINE1 TO LINE2 DO BEGIN
GETTXT(N,TEMP);
PUTMARK(N,(MATCH(TEMP,PAT)=GFLAG))
END;
FOR N:=1 TO LINE1-1 DO
PUTMARK(N,FALSE);
FOR N:=LINE2+1 TO LASTLN DO
PUTMARK(N,FALSE);
STATUS:=OK
END
END;
CKGLOB:=STATUS
END;
FUNCTION DOGLOB(VAR LIN:XSTRING;VAR I,CURSAVE:INTEGER;
VAR STATUS: STCODE):STCODE;
VAR
COUNT,ISTART,N: INTEGER;
BEGIN
STATUS:=OK;
COUNT:=0;
N:=LINE1;
ISTART:=I;
REPEAT
IF(GETMARK(N))THEN BEGIN
PUTMARK(N,FALSE);
CURLN:=N;
CURSAVE:=CURLN;
I:=ISTART;
IF(DOCMD(LIN,I,TRUE,STATUS)=OK)THEN
COUNT:=0
END
ELSE BEGIN
N:=NEXTLN(N);
COUNT:=COUNT + 1
END
UNTIL(COUNT > LASTLN)OR(STATUS <> OK);
DOGLOB:=STATUS
END;
BEGIN
SETBUF;
PAT[1]:=ENDSTR;
SAVEFILE[1]:=ENDSTR;
IF(GETARG(2,SAVEFILE,MAXSTR))THEN
IF(DOREAD(0,SAVEFILE)=ERR)THEN
WRITELN('?');
MORE:=GETLINE(LIN,STDIN,MAXSTR);
WHILE(MORE)DO BEGIN
I:=1;
CURSAVE:=CURLN;
IF(GETLIST(LIN,I,STATUS)=OK)THEN BEGIN
IF(CKGLOB(LIN,I,STATUS)=OK)THEN
STATUS:=DOGLOB(LIN,I,CURSAVE,STATUS)
ELSE IF(STATUS<>ERR)THEN
STATUS:=DOCMD(LIN,I,FALSE,STATUS)
END;
IF(STATUS=ERR)THEN BEGIN
WRITELN('?');
CURLN:=MIN(CURSAVE,LASTLN)
END
ELSE IF(STATUS=ENDDATA)THEN
MORE:=FALSE;
IF(MORE)THEN
MORE:=GETLINE(LIN,STDIN,MAXSTR)
END;
CLRBUF
END;
SHAR_EOF
if test 16451 -ne "`wc -c < 'chapter6.pas'`"
then
echo shar: error transmitting "'chapter6.pas'" '(should have been 16451 characters)'
fi
fi # end of overwriting check
if test -f 'chapter7.pas'
then
echo shar: will not over-write existing file "'chapter7.pas'"
else
cat << \SHAR_EOF > 'chapter7.pas'
{chapter7.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 FORMAT;
CONST
CMD=PERIOD;
PAGENUM=SHARP;
PAGEWIDTH=60;
PAGELEN=66;
HUGE=10000;
TYPE
CMDTYPE=(BP,BR,CE,FI,FO,HE,IND,LS,NF,PL,
RM,SP,TI,UL,UNKNOWN);
VAR
CURPAGE,NEWPAGE,LINENO:INTEGER;
PLVAL,M1VAL,M2VAL,M3VAL,M4VAL:INTEGER;
BOTTOM:INTEGER;
HEADER,FOOTER:XSTRING;
FILL:BOOLEAN;
LSVAL,SPVAL,INVAL,RMVAL,TIVAL,CEVAL,ULVAL:INTEGER;
OUTP,OUTW,OUTWDS:INTEGER;
OUTBUF:XSTRING;
DIR:0..1;
INBUF:XSTRING;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK) OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETVAL(VAR BUF:XSTRING;VAR ARGTYPE:INTEGER):INTEGER;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
ARGTYPE:=BUF[I];
IF(ARGTYPE=PLUS) OR (ARGTYPE=MINUS) THEN
I:=I+1;
GETVAL:=CTOI(BUF,I)
END;
PROCEDURE SETPARAM(VAR PARAM:INTEGER;VAL,ARGTYPE,DEFVAL,MINVAL,MAXVAL:
INTEGER);
BEGIN
IF(ARGTYPE=NEWLINE)THEN
PARAM:=DEFVAL
ELSE IF (ARGTYPE=PLUS)THEN
PARAM:=PARAM+VAL
ELSE IF(ARGTYPE=MINUS) THEN
PARAM:=PARAM-VAL
ELSE PARAM:=VAL;
PARAM:=MIN(PARAM,MAXVAL);
PARAM:=MAX(PARAM,MINVAL)
END;
PROCEDURE SKIP(N:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO N DO
PUTC(NEWLINE)
END;
PROCEDURE PUTTL(VAR BUF:XSTRING;PAGENO:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO XLENGTH(BUF) DO
IF(BUF[I]=PAGENUM) THEN
PUTDEC(PAGENO,1)
ELSE
PUTC(BUF[I])
END;
PROCEDURE PUTFOOT;
BEGIN
SKIP(M3VAL);
IF(M4VAL>0) THEN BEGIN
PUTTL(FOOTER,CURPAGE);
SKIP(M4VAL-1)
END
END;
PROCEDURE PUTHEAD;
BEGIN
CURPAGE:=NEWPAGE;
NEWPAGE:=NEWPAGE+1;
IF(M1VAL>0)THEN BEGIN
SKIP(M1VAL-1);
PUTTL(HEADER,CURPAGE)
END;
SKIP(M2VAL);
LINENO:=M1VAL+M2VAL+1
END;
PROCEDURE PUT(VAR BUF:XSTRING);
VAR
I:INTEGER;
BEGIN
IF(LINENO<=0) OR(LINENO>BOTTOM) THEN
PUTHEAD;
FOR I:=1 TO INVAL+TIVAL DO
PUTC(BLANK);
TIVAL:=0;
PUTSTR(BUF,STDOUT);
SKIP(MIN(LSVAL-1,BOTTOM-LINENO));
LINENO:=LINENO+LSVAL;
IF(LINENO>BOTTOM)THEN PUTFOOT
END;
PROCEDURE BREAK;
BEGIN
IF(OUTP>0) THEN BEGIN
OUTBUF[OUTP]:=NEWLINE;
OUTBUF[OUTP+1]:=ENDSTR;
PUT(OUTBUF)
END;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
PROCEDURE LEADBL(VAR BUF:XSTRING);
VAR I,J:INTEGER;
BEGIN
BREAK;
I:=1;
WHILE(BUF[I]=BLANK) DO
I:=I+1;
IF(BUF[I]<>NEWLINE) THEN
TIVAL:=TIVAL+I-1;
FOR J:=I TO XLENGTH(BUF)+1 DO
BUF[J-I+1]:=BUF[J]
END;
PROCEDURE GETTL(VAR BUF,TTL:XSTRING);
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
IF(BUF[I]=SQUOTE) OR(BUF[I]=DQUOTE)THEN
I:=I+1;
SCOPY(BUF,I,TTL,1)
END;
PROCEDURE SPACE(N:INTEGER);
BEGIN
BREAK;
IF (LINENO<=BOTTOM) THEN BEGIN
IF(LINENO<=0)THEN
PUTHEAD;
SKIP(MIN(N,BOTTOM+1-LINENO));
LINENO:=LINENO+N;
IF(LINENO>BOTTOM) THEN
PUTFOOT
END
END;
PROCEDURE PAGE;
BEGIN
BREAK;
IF(LINENO>0) AND (LINENO<=BOTTOM) THEN BEGIN
SKIP(BOTTOM+1-LINENO);putfoot
END;
LINENO:=0
END;
FUNCTION WIDTH(VAR BUF:XSTRING):INTEGER;
VAR
I,W:INTEGER;
BEGIN
W:=0;
I:=1;
WHILE(BUF[I]<>ENDSTR) DO BEGIN
IF (BUF[I] = BACKSPACE) THEN
W:=W-1
ELSE IF (BUF[I]<>NEWLINE) THEN
W:=W+1;I:=I+1
END;
WIDTH:=W
END;
PROCEDURE SPREAD(VAR BUF:XSTRING;
OUTP,NEXTRA,OUTWDS:INTEGER);
VAR
I,J,NB,NHOLES:INTEGER;
BEGIN
IF(NEXTRA>0) AND (OUTWDS>1) THEN BEGIN
DIR:=1-DIR;
NHOLES:=OUTWDS-1;
I:=OUTP-1;
J:=MIN(MAXSTR-2,I+NEXTRA);
WHILE(I<J) DO BEGIN
BUF[J]:=BUF[I];
IF(BUF[I]=BLANK) THEN BEGIN
IF(DIR=0) THEN
NB:=(NEXTRA-1) DIV NHOLES +1
ELSE NB:=NEXTRA DIV NHOLES;
NEXTRA:=NEXTRA - NB;
NHOLES:=NHOLES-1;
WHILE(NB>0) DO BEGIN
J:=J-1;
BUF[J]:=BLANK;
NB:=NB-1
END
END;
I:=I-1;
J:=J-1
END
END
END;
PROCEDURE PUTWORD(VAR WORDBUF:XSTRING);
VAR
LAST,LLVAL,NEXTRA,W:INTEGER;
BEGIN
W:=WIDTH(WORDBUF);
LAST:=XLENGTH(WORDBUF)+OUTP+1;
LLVAL:=RMVAL-TIVAL-INVAL;
IF(OUTP>0)
AND ((OUTW+W>LLVAL) OR (LAST >=MAXSTR)) THEN BEGIN
LAST:=LAST-OUTP;
NEXTRA:=LLVAL-OUTW+1;
IF(NEXTRA >0) AND(OUTWDS>1) THEN BEGIN
SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS);
OUTP:=OUTP+NEXTRA
END;
BREAK
END;
SCOPY(WORDBUF,1,OUTBUF,OUTP+1);
OUTP:=LAST;
OUTBUF[OUTP]:=BLANK;
OUTW:=OUTW+W+1;
OUTWDS:=OUTWDS+1
END;
PROCEDURE CENTER(VAR BUF:XSTRING);
BEGIN
TIVAL:=MAX((RMVAL+TIVAL-WIDTH(BUF)) DIV 2,0)
END;
PROCEDURE UNDERLN (VAR BUF:XSTRING;SIZE:INTEGER);
VAR
I,J:INTEGER;
TBUF:XSTRING;
BEGIN
J:=1;
I:=1;
WHILE(BUF[I]<>NEWLINE) AND (J<SIZE-1)DO BEGIN
IF(ISALPHANUM(BUF[I])) THEN BEGIN
TBUF[J]:=UNDERLINE;
TBUF[J+1]:=BACKSPACE;
J:=J+2
END;
TBUF[J]:=BUF[I];
J:=J+1;
I:=I+1
END;
TBUF[J]:=NEWLINE;
TBUF[J+1]:=ENDSTR;
SCOPY(TBUF,1,BUF,1)
END;
PROCEDURE TEXT(VAR INBUF:XSTRING);
VAR
WORDBUF:XSTRING;
I:INTEGER;
BEGIN
IF(INBUF[1]=BLANK) OR (INBUF[1]=NEWLINE) THEN
LEADBL(INBUF);
IF(ULVAL>0) THEN BEGIN
UNDERLN(INBUF,MAXSTR);
ULVAL:=ULVAL-1
END;
IF(CEVAL>0)THEN BEGIN
CENTER(INBUF);
PUT(INBUF);
CEVAL:=CEVAL-1
END
ELSE IF (INBUF[1]=NEWLINE)THEN
PUT(INBUF)
ELSE IF(NOT FILL) THEN
PUT(INBUF)
ELSE BEGIN
I:=1;
REPEAT
I:=GETWORD(INBUF,I,WORDBUF);
IF(I>0)THEN
PUTWORD(WORDBUF)
UNTIL(I=0)
END
END;
PROCEDURE INITFMT;
BEGIN
FILL:=TRUE;
DIR:=0;
INVAL:=0;
RMVAL:=PAGEWIDTH;
TIVAL:=0;
LSVAL:=1;
SPVAL:=0;
CEVAL:=0;
ULVAL:=0;
LINENO:=0;
CURPAGE:=0;
NEWPAGE:=1;
PLVAL:=PAGELEN;
M1VAL:=3;M2VAL:=2;M3VAL:=2;M4VAL:=3;
BOTTOM:=PLVAL-M3VAL-M4VAL;
HEADER[1]:=NEWLINE;
HEADER[2]:=ENDSTR;
FOOTER[1]:=NEWLINE;
FOOTER[2]:=ENDSTR;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETCMD(VAR BUF:XSTRING):CMDTYPE;
VAR
CMD:PACKED ARRAY[1..2] OF CHAR;
BEGIN
CMD[1]:=CHR(BUF[2]);
CMD[2]:=CHR(BUF[3]);
IF(CMD='fi')THEN GETCMD:=FI
ELSE IF (CMD='nf')THEN GETCMD:=NF
ELSE IF (CMD='br')THEN GETCMD:=BR
ELSE IF (CMD='ls')THEN GETCMD:=LS
ELSE IF (CMD='bp')THEN GETCMD:=BP
ELSE IF (CMD='sp')THEN GETCMD:=SP
ELSE IF (CMD='in')THEN GETCMD:=IND
ELSE IF (CMD='rm')THEN GETCMD:=RM
ELSE IF (CMD='ce')THEN GETCMD:=CE
ELSE IF (CMD='ti')THEN GETCMD:=TI
ELSE IF (CMD='ul')THEN GETCMD:=UL
ELSE IF (CMD='he') THEN GETCMD:=HE
ELSE IF (CMD='fo') THEN GETCMD:=FO
ELSE IF (CMD='pl') THEN GETCMD:=PL
ELSE GETCMD:=UNKNOWN
END;
PROCEDURE COMMAND(VAR BUF:XSTRING);
VAR CMD:CMDTYPE;
ARGTYPE,SPVAL,VAL:INTEGER;
BEGIN
CMD:=GETCMD(BUF);
IF(CMD<>UNKNOWN)THEN
VAL:=GETVAL(BUF,ARGTYPE);
CASE CMD OF
FI:BEGIN
BREAK;
FILL:=TRUE END;
NF:BEGIN BREAK;
FILL:=FALSE END;
BR:BREAK;
LS:SETPARAM(LSVAL,VAL,ARGTYPE,1,1,HUGE);
CE:BEGIN BREAK;
SETPARAM(CEVAL,VAL,ARGTYPE,1,0,HUGE) END;
UL:SETPARAM(ULVAL,VAL,ARGTYPE,1,0,HUGE);
HE:GETTL(BUF,HEADER);
FO:GETTL(BUF,FOOTER);
BP:BEGIN PAGE;
SETPARAM(CURPAGE,VAL,ARGTYPE,CURPAGE+1,-HUGE,HUGE);
NEWPAGE:=CURPAGE END;
SP:BEGIN
SETPARAM(SPVAL,VAL,ARGTYPE,1,0,HUGE);
space(spval)
END;
IND:SETPARAM(INVAL,VAL,ARGTYPE,0,0,RMVAL-1);
RM:SETPARAM(INVAL,VAL,ARGTYPE,PAGEWIDTH,
INVAL+TIVAL+1,HUGE);
TI:BEGIN BREAK;
SETPARAM(TIVAL,VAL,ARGTYPE,0,-HUGE,RMVAL) END;
PL:BEGIN
SETPARAM(PLVAL,VAL,ARGTYPE,PAGELEN,
M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE);
BOTTOM:=PLVAL-M3VAL-M4VAL END;
UNKNOWN:
END
END;
BEGIN
INITFMT;
WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO
IF(INBUF[1]=CMD) THEN
COMMAND(INBUF)
ELSE
TEXT(INBUF);
PAGE
END;
SHAR_EOF
if test 8627 -ne "`wc -c < 'chapter7.pas'`"
then
echo shar: error transmitting "'chapter7.pas'" '(should have been 8627 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0reintom@rocky2.UUCP (Tom Reingold) (09/19/86)
#! /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 0reintom@rocky2.UUCP (Tom Reingold) (10/01/86)
#! /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:
# README.V30
# chapter1.pas
# chapter2.pas
# chapter3.pas
# chapter4.pas
# This archive created: Thu Sep 18 14:16:10 1986
export PATH; PATH=/bin:$PATH
if test -f 'README.V30'
then
echo shar: will not over-write existing file "'README.V30'"
else
cat << \SHAR_EOF > 'README.V30'
{readme.v30}
TURBTOOL.LBR DOCUMENTATION
This library contains the source from the book
"Software Tools in Pascal" by B.W. Kernighan and
P.J. Plauger, Addison-Wesley. It has been adapted
for Turbo Pascal.
How to Implement:
Compile SHELL.PAS with the CMD option
Execute SHELL
Accepts redirection, but not pipes.
Bill McGee, 613-828-9130
Notes: The version using TURBO is fast enough to make
this a useful set of tools for file manipulation.
------Further Modifications------
The primitives in this version are basically the UCSD Pascal versions
presented in the book, with modifications for Turbo Pascal.
This version has been modified for use under Turbo Pascal v. 3.0
under CP/M-86. There are no system dependent statements in the code
to the best of my knowledge, so it should work under MS-DOS as well.
The original version (typed in by Bill McGee) was set up for CP/M-80 and
used the CHAIN capability of Turbo Pascal. I have eliminated that
feature in favor of using INCLUDE files. There is not enough memory
available in a CP/M-80 system for this version, but one could modify
the include file list to eliminate unwanted features or to make more
than one version, (e.g. break out EDIT, FORMAT, and DEFINE).
There was really only one change required to the McGee's original to get
it to work with version 3.0. A readln(TRM) had to be added in the
subroutine GETKBD. The change to CP/M-86 required replacing all calls
to the procedure BDOS(0,0) with HALT. This change works with the CP/M-80
version of Turbo Pascal v. 3.0 as well. Thus, as anyone can see, all of
the hard work was done by Bill.
(Adaption to version 3.0 of Turbo Pascal by Jim Potter, (505) 662-5804.)
Please note that this is copyright software. The following notice has
been included with each file and should not be removed.
+-------------------------------------------------------------------------+
| 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. |
+-------------------------------------------------------------------------+
SHAR_EOF
if test 3049 -ne "`wc -c < 'README.V30'`"
then
echo shar: error transmitting "'README.V30'" '(should have been 3049 characters)'
fi
fi # end of overwriting check
if test -f 'chapter1.pas'
then
echo shar: will not over-write existing file "'chapter1.pas'"
else
cat << \SHAR_EOF > 'chapter1.pas'
{chapter1.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 COPY;
VAR C:CHARACTER;
BEGIN
WHILE(GETC(C)<>ENDFILE)DO
PUTC(C)
END;
PROCEDURE CHARCOUNT;
VAR
NC:INTEGER;
C:CHARACTER;
BEGIN
NC:=0;
WHILE (GETC(C)<>ENDFILE)DO
NC:=NC+1;
PUTDEC(NC,1);
PUTC(NEWLINE)
END;
PROCEDURE LINECOUNT;
VAR
N1:INTEGER;
C:CHARACTER;
BEGIN
N1:=0;
WHILE(GETC(C)<>ENDFILE)DO
IF(C=NEWLINE)THEN
N1:=N1+1;
PUTDEC(N1,1);
PUTC(NEWLINE)
END;
PROCEDURE WORDCOUNT;
VAR
NW:INTEGER;
C:CHARACTER;
INWORD:BOOLEAN;
BEGIN
NW:=0;
INWORD:=FALSE;
WHILE(GETC(C)<>ENDFILE)DO
IF(C=BLANK)OR(C=NEWLINE)OR(C=TAB) THEN
INWORD:=FALSE
ELSE IF (NOT INWORD)THEN BEGIN
INWORD:=TRUE;
NW:=NW+1
END;
PUTDEC(NW,1);
PUTC(NEWLINE)
END;
PROCEDURE DETAB;
CONST
MAXLINE=1000;
TYPE
TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
C:CHARACTER;
COL:INTEGER;
TABSTOPS:TABTYPE;
FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE)
:BOOLEAN;
BEGIN
IF(COL>MAXLINE)THEN
TABPOS:=TRUE
ELSE
TABPOS:=TABSTOPS[COL]
END;
PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
TABSPACE=4;
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO MAXLINE DO
TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;
BEGIN
SETTABS(TABSTOPS);
COL:=1;
WHILE(GETC(C)<>ENDFILE)DO
IF(C=TAB)THEN
REPEAT
PUTC(BLANK);
COL:=COL+1
UNTIL(TABPOS(COL,TABSTOPS))
ELSE IF(C=NEWLINE)THEN BEGIN
PUTC(NEWLINE);
COL:=1
END
ELSE BEGIN
PUTC(C);
COL:=COL+1
END
END;
SHAR_EOF
if test 2054 -ne "`wc -c < 'chapter1.pas'`"
then
echo shar: error transmitting "'chapter1.pas'" '(should have been 2054 characters)'
fi
fi # end of overwriting check
if test -f 'chapter2.pas'
then
echo shar: will not over-write existing file "'chapter2.pas'"
else
cat << \SHAR_EOF > 'chapter2.pas'
{chapter2.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 TRANSLIT;FORWARD;
PROCEDURE ENTAB;FORWARD;
PROCEDURE EXPAND;FORWARD;
PROCEDURE ECHO;FORWARD;
PROCEDURE COMPRESS;FORWARD;
PROCEDURE OVERSTRIKE;FORWARD;
PROCEDURE OVERSTRIKE;
CONST
SKIP=BLANK;
NOSKIP=PLUS;
VAR
C:CHARACTER;
COL,NEWCOL,I:INTEGER;
BEGIN
COL:=1;
REPEAT
NEWCOL:=COL;
WHILE(GETC(C)=BACKSPACE) DO
NEWCOL:=MAX(NEWCOL-1,1);
IF (NEWCOL<COL) THEN BEGIN
PUTC(NEWLINE);
PUTC(NOSKIP);
FOR I:=1 TO NEWCOL-1 DO
PUTC(BLANK);
COL:=NEWCOL
END
ELSE IF (COL=1) AND (C<>ENDFILE) THEN
PUTC(SKIP);
IF(C<>ENDFILE)THEN BEGIN
PUTC(C);
IF (C=NEWLINE) THEN
COL:=1
ELSE
COL:=COL+1
END
UNTIL (C=ENDFILE)
END;
PROCEDURE COMPRESS;
CONST
WARNING=CARET;
VAR
C,LASTC:CHARACTER;
N:INTEGER;
PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
MAXREP=26;
THRESH=4;
BEGIN
WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
PUTC(WARNING);
PUTC(MIN(N,MAXREP)-1+ORD('A'));
PUTC(C);
N:=N-MAXREP
END;
FOR N:=N DOWNTO 1 DO
PUTC(C)
END;
BEGIN(*COMPRESS*)
N:=1;
LASTC:=GETC(LASTC);
WHILE(LASTC<>ENDFILE) DO BEGIN
IF(GETC(C)=ENDFILE)THEN BEGIN
IF(N>1) OR(LASTC=WARNING) THEN
PUTREP(N,LASTC)
ELSE
PUTC(LASTC)
END
ELSE IF (C=LASTC) THEN
N:=N+1
ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
PUTREP(N,LASTC);
N:=1
END
ELSE
PUTC(LASTC);
LASTC:=C
END
END;
PROCEDURE EXPAND;
CONST
WARNING=CARET;
VAR
C:CHARACTER;
N:INTEGER;
BEGIN
WHILE(GETC(C)<>ENDFILE) DO
IF (C<>WARNING)THEN
PUTC(C)
ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
N:=C-ORD('A')+1;
IF(GETC(C)<>ENDFILE)THEN
FOR N:=N DOWNTO 1 DO
PUTC(C)
ELSE BEGIN
PUTC(WARNING);
PUTC(N-1+ORD('A'))
END
END
ELSE BEGIN
PUTC(WARNING);
IF(C<>ENDFILE) THEN
PUTC(C)
END
END;
PROCEDURE ECHO;
VAR
I,J:INTEGER;
ARGSTR:XSTRING;
BEGIN
I:=2;
WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
IF(I>1) THEN PUTC(BLANK);
FOR J:=1 TO XLENGTH(ARGSTR) DO
PUTC(ARGSTR[J]);
I:=I+1
END;
IF(I>1)THEN PUTC(NEWLINE)
END;
PROCEDURE ENTAB;
CONST
MAXLINE=1000;
TYPE
TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
C:CHARACTER;
COL,NEWCOL:INTEGER;
TABSTOPS:TABTYPE;
FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
BEGIN
IF(COL>MAXLINE)THEN
TABPOS:=TRUE
ELSE
TABPOS:=TABSTOPS[COL]
END;
PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
TABSPACE=4;
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO MAXLINE DO
TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;
BEGIN
SETTABS(TABSTOPS);
COL:=1;
REPEAT
NEWCOL:=COL;
WHILE(GETC(C)=BLANK) DO BEGIN
NEWCOL:=NEWCOL+1;
IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
PUTC(TAB);
COL:=NEWCOL;
END
END;
WHILE (COL<NEWCOL) DO BEGIN
PUTC(BLANK);
COL:=COL+1
END;
IF(C<>ENDFILE) THEN BEGIN
PUTC(C);
IF(C=NEWLINE) THEN
COL:=1
ELSE
COL:=COL+1
END
UNTIL(C=ENDFILE)
END;
PROCEDURE TRANSLIT;
CONST
NEGATE=CARET;
VAR
ARG,FROMSET,TOSET:XSTRING;
C:CHARACTER;
I,LASTTO:0..MAXSTR;
ALLBUT,SQUASH:BOOLEAN;
FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
BEGIN
IF(C=ENDFILE)THEN XINDEX:=0
ELSE IF (NOT ALLBUT) THEN
XINDEX:=INDEX(INSET,C)
ELSE IF(INDEX(INSET,C)>0)THEN
XINDEX:=0
ELSE
XINDEX:=LASTTO+1
END;
FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;
VAR J:INTEGER;
PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
VAR I:INTEGER;VAR DEST:XSTRING;
VAR J:INTEGER;MAXSET:INTEGER);
VAR
K:INTEGER;
JUNK:BOOLEAN;
BEGIN
WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
IF(SRC[I]=ATSIGN)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;(*DODASH*)
BEGIN(*MAKESET*)
J:=1;
DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
END;(*MAKESET*)
BEGIN(*TRANSLIT*)
IF (NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:TRANSLIT FROM TO');
ALLBUT:=(ARG[1]=NEGATE);
IF(ALLBUT)THEN
I:=2
ELSE
I:=1;
IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
ERROR('TRANSLIT:"FROM"SET TOO LARGE');
IF(NOT GETARG(3,ARG,MAXSTR))THEN
TOSET[1]:=ENDSTR
ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
ERROR('TRANSLIT:"TO"SET TOO LARGE')
ELSE IF (XLENGTH(FROMSET)<XLENGTH(TOSET))THEN
ERROR('TRANSLIT:"FROM"SHORTER THAN "TO');
LASTTO:=XLENGTH(TOSET);
SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
REPEAT
I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
PUTC(TOSET[LASTTO]);
REPEAT
I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
UNTIL (I<LASTTO)
END;
IF(C<>ENDFILE) THEN BEGIN
IF(I>0)AND(LASTTO>0) THEN
PUTC(TOSET[I])
ELSE IF (I=0)THEN
PUTC(C)
(*ELSE DELETE*)
END
UNTIL(C=ENDFILE)
END;
SHAR_EOF
if test 6124 -ne "`wc -c < 'chapter2.pas'`"
then
echo shar: error transmitting "'chapter2.pas'" '(should have been 6124 characters)'
fi
fi # end of overwriting check
if test -f 'chapter3.pas'
then
echo shar: will not over-write existing file "'chapter3.pas'"
else
cat << \SHAR_EOF > 'chapter3.pas'
{chapter3.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 COMPARE;FORWARD;
PROCEDURE INCLUDE;FORWARD;
PROCEDURE CONCAT;FORWARD;
PROCEDURE MAKECOPY;
VAR
INNAME,OUTNAME:XSTRING;
FIN,FOUT:FILEDESC;
BEGIN
IF(NOT GETARG(2,INNAME,MAXSTR))
OR (NOT GETARG(3,OUTNAME,MAXSTR))THEN
ERROR('USAGE:MAKECOPY OLD NEW');
FIN:=MUSTOPEN(INNAME,IOREAD);
FOUT:=MUSTCREATE(OUTNAME,IOWRITE);
FCOPY(FIN,FOUT);
XCLOSE(FIN);
XCLOSE(FOUT)
END;
PROCEDURE PRINT;
VAR
NAME:XSTRING;
NULL:XSTRING;
I:INTEGER;
FIN:FILEDESC;
JUNK:BOOLEAN;
PROCEDURE FPRINT(VAR NAME:XSTRING;FIN:FILEDESC);
CONST
MARGIN1=2;
MARGIN2=2;
BOTTOM=64;
PAGELEN=66;
VAR
LINE:XSTRING;
LINENO,PAGENO:INTEGER;
PROCEDURE SKIP(N:INTEGER);
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO N DO
PUTC(NEWLINE)
END;
PROCEDURE HEAD(VAR NAME:XSTRING;PAGENO:INTEGER);
VAR
PAGE:XSTRING;
BEGIN
PAGE[1]:=ORD(' ');
PAGE[2]:=ORD('P');
PAGE[3]:=ORD('a');
PAGE[4]:=ORD('g');
PAGE[5]:=ORD('e');
PAGE[6]:=ORD(' ');
PAGE[7]:=ENDSTR;
PUTSTR(NAME,STDOUT);
PUTSTR(PAGE,STDOUT);
PUTDEC(PAGENO,1);
PUTC(NEWLINE)
END;
BEGIN(*FPRINT*)
PAGENO:=1;
SKIP(MARGIN1);
HEAD(NAME,PAGENO);
SKIP(MARGIN2);
LINENO:=MARGIN1+MARGIN2+1;
WHILE(GETLINE(LINE,FIN,MAXSTR))DO BEGIN
IF(LINENO=0)THEN BEGIN
SKIP(MARGIN1);;
PAGENO:=PAGENO+1;
HEAD(NAME,PAGENO);
SKIP(MARGIN2);
LINENO:=MARGIN1+MARGIN2+1
END;
PUTSTR(LINE,STDOUT);
LINENO:=LINENO+1;
IF(LINENO>=BOTTOM)THEN BEGIN
SKIP(PAGELEN-LINENO);
LINENO:=0
END
END;
IF(LINENO>0)THEN
SKIP(PAGELEN-LINENO)
END;
BEGIN(*PRINT*)
NULL[1]:=ENDSTR;
IF(NARGS=1)THEN
FPRINT(NULL,STDIN)
ELSE
FOR I:=2 TO NARGS DO BEGIN
JUNK:=GETARG(I,NAME,MAXSTR);
FIN:=MUSTOPEN(NAME,IOREAD);
FPRINT(NAME,FIN);
XCLOSE(FIN)
END
END;
PROCEDURE COMPARE;
VAR
LINE1,LINE2:XSTRING;
ARG1,ARG2:XSTRING;
LINENO:INTEGER;
INFILE1,INFILE2:FILEDESC;
F1,F2:BOOLEAN;
PROCEDURE DIFFMSG (N:INTEGER; VAR LINE1,LINE2:XSTRING);
BEGIN
PUTDEC(N,1);
PUTC(COLON);
PUTC(NEWLINE);
PUTSTR(LINE1,STDOUT);
PUTSTR(LINE2,STDOUT)
END;
BEGIN(*COMPARE*)
IF (NOT GETARG(2,ARG1,MAXSTR))
OR (NOT GETARG(3,ARG2,MAXSTR)) THEN
ERROR('USAGE:COMPARE FILE1 FILE2');
INFILE1:=MUSTOPEN(ARG1,IOREAD);
INFILE2:=MUSTOPEN(ARG2,IOREAD);
LINENO:=0;
REPEAT
LINENO:=LINENO+1;
F1:=GETLINE(LINE1,INFILE1,MAXSTR);
F2:=GETLINE(LINE2,INFILE2,MAXSTR);
IF (F1 AND F2) THEN
IF (NOT EQUAL(LINE1,LINE2)) THEN
DIFFMSG(LINENO,LINE1,LINE2)
UNTIL (F1=FALSE) OR (F2=FALSE);
IF(F2 AND NOT F1) THEN
WRITELN('COMPARE:END OF FILE ON FILE 1')
ELSE IF (F1 AND NOT F2) THEN
WRITELN('COMPARE:END OF FILE ON FILE2')
END;
PROCEDURE INCLUDE;
VAR
INCL:XSTRING;
PROCEDURE FINCLUDE(F:FILEDESC);
VAR
LINE,STR:XSTRING;
LOC,I:INTEGER;
F1:FILEDESC;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
BEGIN
WHILE (GETLINE(LINE,F,MAXSTR))DO BEGIN
LOC:=GETWORD(LINE,1,STR);
IF (NOT EQUAL(STR,INCL)) THEN
PUTSTR(LINE,STDOUT)
ELSE BEGIN
LOC:=GETWORD(LINE,LOC,STR);
STR[XLENGTH(STR)]:=ENDSTR;
FOR I:= 1 TO XLENGTH(STR)DO
STR[I]:=STR[I+1];
F1:=MUSTOPEN(STR,IOREAD);
FINCLUDE(F1);
XCLOSE(F1)
END
END
END;
BEGIN
INCL[1]:=ORD('#');
INCL[2]:=ORD('i');
INCL[3]:=ORD('n');
INCL[4]:=ORD('c');
INCL[5]:=ORD('l');
INCL[6]:=ORD('u');
INCL[7]:=ORD('d');
INCL[8]:=ORD('e');
INCL[9]:=ENDSTR;
FINCLUDE(STDIN)
END;
PROCEDURE CONCAT;
VAR
I:INTEGER;
JUNK:BOOLEAN;
FD:FILEDESC;
S:XSTRING;
BEGIN
FOR I:=2 TO NARGS DO BEGIN
JUNK:=GETARG(I,S,MAXSTR);
FD:=MUSTOPEN(S,IOREAD);
FCOPY(FD,STDOUT);
XCLOSE(FD)
END
END;
PROCEDURE ARCHIVE;
CONST
MAXFILES=10;
VAR
ANAME:XSTRING;
CMD:XSTRING;
FNAME:ARRAY[1..MAXFILES]OF XSTRING;
FSTAT:ARRAY[1..MAXFILES] OF BOOLEAN;
NFILES:INTEGER;
ERRCOUNT:INTEGER;
ARCHTEMP:XSTRING;
ARCHHDR:XSTRING;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE (S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
FUNCTION GETHDR(FD:FILEDESC;VAR BUF,NAME:XSTRING;
VAR SIZE:INTEGER):BOOLEAN;
VAR
TEMP:XSTRING;
I:INTEGER;
BEGIN
IF(GETLINE(BUF,FD,MAXSTR)=FALSE)THEN
GETHDR:=FALSE
ELSE BEGIN
I:=GETWORD(BUF,1,TEMP);
IF(NOT EQUAL(TEMP,ARCHHDR))THEN
ERROR('ARCHIVE NOT IN PROPER FORMAT');
I:=GETWORD(BUF,I,NAME);
SIZE:=CTOI(BUF,I);
GETHDR:=TRUE
END
END;
FUNCTION FILEARG (VAR NAME:XSTRING):BOOLEAN;
VAR
I:INTEGER;
FOUND:BOOLEAN;
BEGIN
IF(NFILES<=0)THEN
FILEARG:=TRUE
ELSE BEGIN
FOUND:=FALSE;
I:=1;
WHILE(NOT FOUND) AND (I<=NFILES)DO BEGIN
IF(EQUAL(NAME,FNAME[I])) THEN BEGIN
FSTAT[I]:=TRUE;
FOUND:=TRUE
END;
I:=I+1
END;
FILEARG:=FOUND
END
END;
PROCEDURE FSKIP(FD:FILEDESC;N:INTEGER);
VAR
C:CHARACTER;
I:INTEGER;
BEGIN
FOR I:=1 TO N DO
IF(GETCF(C,FD)=ENDFILE)THEN
ERROR('ARCHIVE:END OF FILE IN FSKIP')
END;
PROCEDURE FMOVE(VAR NAME1,NAME2:XSTRING);
VAR
FD1,FD2:FILEDESC;
BEGIN
FD1:=MUSTOPEN(NAME1,IOREAD);
FD2:=MUSTCREATE(NAME2,IOWRITE);
FCOPY(FD1,FD2);
XCLOSE(FD1);
XCLOSE(FD2)
END;
PROCEDURE ACOPY(FDI,FDO:FILEDESC;N:INTEGER);
VAR
C:CHARACTER;
I:INTEGER;
BEGIN
FOR I:=1 TO N DO
IF (GETCF(C,FDI)=ENDFILE)THEN
ERROR('ARCHIVE: END OF FILE IN ACOPY')
ELSE
PUTCF(C,FDO)
END;
PROCEDURE NOTFOUND;
VAR
I:INTEGER;
BEGIN
FOR I := 1 TO NFILES DO
IF(FSTAT[I]=FALSE)THEN BEGIN
PUTSTR(FNAME[I],STDERR);
WRITELN(':NOT IN ARCHIVE');
ERRCOUNT:=ERRCOUNT + 1
END
END;
PROCEDURE ADDFILE(VAR NAME:XSTRING;FD:FILEDESC);
VAR
HEAD:XSTRING;
NFD:FILEDESC;
PROCEDURE MAKEHDR(VAR NAME,HEAD:XSTRING);
VAR
I:INTEGER;
FUNCTION FSIZE(VAR NAME:XSTRING):INTEGER;
VAR
C:CHARACTER;
FD:FILEDESC;
N:INTEGER;
BEGIN
N:=0;
FD:=MUSTOPEN(NAME,IOREAD);
WHILE(GETCF(C,FD)<>ENDFILE)DO
N:=N+1;
XCLOSE(FD);
FSIZE:=N
END;
BEGIN
SCOPY(ARCHHDR,1,HEAD,1);
I:=XLENGTH(HEAD)+1;
HEAD[I]:=BLANK;
SCOPY(NAME,1,HEAD,I+1);
I:=XLENGTH(HEAD)+1;
HEAD[I]:=BLANK;
I:=ITOC(FSIZE(NAME),HEAD,I+1);
HEAD[I]:=NEWLINE;
HEAD[I+1]:=ENDSTR
END;
BEGIN
NFD:=OPEN(NAME,IOREAD);
IF(NFD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
WRITELN(':CAN''T ADD');
ERRCOUNT:=ERRCOUNT+1
END;
IF(ERRCOUNT=0)THEN BEGIN
MAKEHDR(NAME,HEAD);
PUTSTR(HEAD,FD);
FCOPY(NFD,FD);
XCLOSE(NFD)
END
END;
PROCEDURE REPLACE(AFD,TFD:FILEDESC;CMD:INTEGER);
VAR
PINLINE,UNAME:XSTRING;
SIZE:INTEGER;
BEGIN
WHILE(GETHDR(AFD,PINLINE,UNAME,SIZE))DO
IF(FILEARG(UNAME))THEN BEGIN
IF(CMD=ORD('U'))THEN
ADDFILE(UNAME,TFD);
FSKIP(AFD,SIZE)
END
ELSE BEGIN
PUTSTR(PINLINE,TFD);
ACOPY(AFD,TFD,SIZE)
END
END;
PROCEDURE HELP;
BEGIN
ERROR('USAGE:ARCHIVE -[CDPTUX] ARCHNAME [FILES...]')
END;
PROCEDURE GETFNS;
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
ERRCOUNT:=0;
NFILES:=NARGS-3;
IF(NFILES>MAXFILES)THEN
ERROR('ARCHIVE:TO MANY FILE NAMES');
FOR I:=1 TO NFILES DO
JUNK:=GETARG(I+3,FNAME[I],MAXSTR);
FOR I:=1 TO NFILES DO
FSTAT[I]:=FALSE;
FOR I:=1 TO NFILES-1 DO
FOR J:=I+1 TO NFILES DO
IF(EQUAL(FNAME[I],FNAME[J]))THEN BEGIN
PUTSTR(FNAME[I],STDERR);
ERROR(':DUPLICATE FILENAME')
END
END;
PROCEDURE UPDATE(VAR ANAME:XSTRING;CMD:CHARACTER);
VAR
I:INTEGER;
AFD,TFD:FILEDESC;
BEGIN
TFD:=MUSTCREATE(ARCHTEMP,IOWRITE);
IF(CMD=ORD('u')) THEN BEGIN
AFD:=MUSTOPEN(ANAME,IOREAD);
REPLACE(AFD,TFD,ORD('u'));(*UPDATE EXISTING*)
XCLOSE(AFD)
END;
FOR I:=1 TO NFILES DO
IF(FSTAT[I]=FALSE)THEN BEGIN
ADDFILE(FNAME[I],TFD);
FSTAT[I]:=TRUE
END;
XCLOSE(TFD);
IF(ERRCOUNT=0)THEN
FMOVE(ARCHTEMP,ANAME)
ELSE
WRITELN('FATAL ERRORS - ARCHIVE NOT ALTERED');
REMOVE (ARCHTEMP)
END;
PROCEDURE TABLE(VAR ANAME:XSTRING);
VAR
HEAD,NAME:XSTRING;
SIZE:INTEGER;
AFD:FILEDESC;
PROCEDURE TPRINT(VAR BUF:XSTRING);
VAR
I:INTEGER;
TEMP:XSTRING;
BEGIN
I:=GETWORD(BUF,1,TEMP);
I:=GETWORD(BUF,I,TEMP);
PUTSTR(TEMP,STDOUT);
PUTC(BLANK);
I:=GETWORD(BUF,I,TEMP);(*SIZE*)
PUTSTR(TEMP,STDOUT);
PUTC(NEWLINE)
END;
BEGIN
AFD:=MUSTOPEN(ANAME,IOREAD);
WHILE(GETHDR(AFD,HEAD,NAME,SIZE))DO BEGIN
IF(FILEARG(NAME))THEN
TPRINT(HEAD);
FSKIP(AFD,SIZE)
END;
NOTFOUND
END;
PROCEDURE EXTRACT (VAR ANAME:XSTRING;CMD:CHARACTER);
VAR
ENAME,PINLINE:XSTRING;
AFD,EFD:FILEDESC;
SIZE : INTEGER;
BEGIN
AFD:=MUSTOPEN(ANAME,IOREAD);
IF (CMD=ORD('p')) THEN
EFD:=STDOUT
ELSE
EFD:=IOERROR;
WHILE (GETHDR(AFD,PINLINE,ENAME,SIZE)) DO
IF (NOT FILEARG(ENAME))THEN
FSKIP(AFD,SIZE)
ELSE
BEGIN
IF (EFD<> STDOUT) THEN
EFD:=CREATE(ENAME,IOWRITE);
IF(EFD=IOERROR) THEN BEGIN
PUTSTR(ENAME,STDERR);
WRITELN(': CANT''T CREATE');
ERRCOUNT:=ERRCOUNT+1;
FSKIP(AFD,SIZE)
END
ELSE BEGIN
ACOPY(AFD,EFD,SIZE);
IF(EFD<>STDOUT)THEN
XCLOSE(EFD)
END
END;
NOTFOUND
END;
PROCEDURE DELETE(VAR ANAME:XSTRING);
VAR
AFD,TFD:FILEDESC;
BEGIN
IF(NFILES<=0)THEN(*PROTECT INNOCENT*)
ERROR('ARCHIVE:-D REQUIRES EXPLICIT FILE NAMES');
AFD:=MUSTOPEN(ANAME,IOREAD);
TFD:=MUSTCREATE(ARCHTEMP,IOWRITE);
REPLACE(AFD,TFD,ORD('d'));
NOTFOUND;
XCLOSE(AFD);
XCLOSE(TFD);
IF(ERRCOUNT=0)THEN
FMOVE(ARCHTEMP,ANAME)
ELSE
WRITELN('FATAL ERRORS - ARCHIVE NOT ALTERED');
REMOVE(ARCHTEMP)
END;
PROCEDURE INITARCH;
BEGIN
ARCHTEMP[1]:=ORD('A');
ARCHTEMP[2]:=ORD('R');
ARCHTEMP[3]:=ORD('T');
ARCHTEMP[4]:=ORD('E');
ARCHTEMP[5]:=ORD('M');
ARCHTEMP[6]:=ORD('P');
ARCHTEMP[7]:=ENDSTR;
ARCHHDR[1]:=ORD('-');
ARCHHDR[2]:=ORD('H');
ARCHHDR[3]:=ORD('-');
ARCHHDR[4]:=ENDSTR;
END;
BEGIN
INITARCH;
IF (NOT GETARG(2,CMD,MAXSTR))
OR(NOT GETARG(3,ANAME,MAXSTR)) THEN
HELP;
GETFNS;
IF(XLENGTH(CMD)<>2) OR(CMD[1]<>ORD('-')) THEN
HELP
ELSE IF (CMD[2]=ORD('c'))OR(CMD[2]=ORD('u'))THEN
UPDATE(ANAME,CMD[2])
ELSE IF (CMD[2]=ORD('t'))THEN
TABLE(ANAME)
ELSE IF (CMD[2]=ORD('x'))OR(CMD[2]=ORD('p'))THEN
EXTRACT(ANAME,CMD[2])
ELSE IF (CMD[2]=ORD('d'))THEN
DELETE(ANAME)
ELSE
HELP
END;
SHAR_EOF
if test 11306 -ne "`wc -c < 'chapter3.pas'`"
then
echo shar: error transmitting "'chapter3.pas'" '(should have been 11306 characters)'
fi
fi # end of overwriting check
if test -f 'chapter4.pas'
then
echo shar: will not over-write existing file "'chapter4.pas'"
else
cat << \SHAR_EOF > 'chapter4.pas'
{chapter4.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 SORT;
CONST
MAXCHARS=10000;
MAXLINES=300;
MERGEORDER=5;
TYPE
CHARPOS=1..MAXCHARS;
CHARBUF=ARRAY[1..MAXCHARS] OF CHARACTER;
POSBUF=ARRAY[1..MAXLINES] OF CHARPOS;
POS=0..MAXLINES;
FDBUF=ARRAY[1..MERGEORDER]OF FILEDESC;
VAR
LINEBUF:CHARBUF;
LINEPOS:POSBUF;
NLINES:POS;
INFILE:FDBUF;
OUTFILE:FILEDESC;
HIGH,LOW,LIM:INTEGER;
DONE:BOOLEAN;
NAME:XSTRING;
FUNCTION GTEXT(VAR LINEPOS:POSBUF;VAR NLINES:POS;
VAR LINEBUF:CHARBUF;INFILE:FILEDESC):BOOLEAN;
VAR
I,LEN,NEXTPOS:INTEGER;
TEMP:XSTRING;
DONE:BOOLEAN;
BEGIN
NLINES:=0;
NEXTPOS:=1;
REPEAT
DONE:=(GETLINE(TEMP,INFILE,MAXSTR)=FALSE);
IF(NOT DONE) THEN BEGIN
NLINES:=NLINES+1;
LINEPOS[NLINES]:=NEXTPOS;
LEN:=XLENGTH(TEMP);
FOR I:=1 TO LEN DO
LINEBUF[NEXTPOS+I-1]:=TEMP[I];
LINEBUF[NEXTPOS+LEN]:=ENDSTR;
NEXTPOS:=NEXTPOS+LEN+1
END
UNTIL (DONE) OR (NEXTPOS>= MAXCHARS-MAXSTR)
OR (NLINES>=MAXLINES);
GTEXT:=DONE
END;
PROCEDURE PTEXT(VAR LINEPOS:POSBUF;NLINES:INTEGER;
VAR LINEBUF:CHARBUF;OUTFILE:FILEDESC);
VAR
I,J:INTEGER;
BEGIN
FOR I:=1 TO NLINES DO BEGIN
J:=LINEPOS[I];
WHILE (LINEBUF[J]<>ENDSTR)DO BEGIN
PUTCF(LINEBUF[J],OUTFILE);
J:=J+1
END
END
END;
PROCEDURE EXCHANGE(VAR LP1,LP2:CHARPOS);
VAR
TEMP:CHARPOS;
BEGIN
TEMP:=LP1;
LP1:=LP2;
LP2:=TEMP
END;
FUNCTION CMP (I,J:CHARPOS;VAR LINEBUF:CHARBUF)
:INTEGER;
BEGIN
WHILE(LINEBUF[I]=LINEBUF[J])
AND (LINEBUF[I]<>ENDSTR) DO BEGIN
I:=I+1;
J:=J+1
END;
IF(LINEBUF[I]=LINEBUF[J]) THEN
CMP:=0
ELSE IF (LINEBUF[I]=ENDSTR) THEN
CMP:=-1
ELSE IF (LINEBUF[J]=ENDSTR) THEN
CMP:=+1
ELSE IF (LINEBUF[I]<LINEBUF[J]) THEN
CMP:=-1
ELSE
CMP:=+1
END;(*CMP*)
PROCEDURE QUICK(VAR LINEPOS:POSBUF; NLINE:POS;
VAR LINEBUF:CHARBUF);
PROCEDURE RQUICK(LO,HI:INTEGER);
VAR
I,J:INTEGER;
PIVLINE:CHARPOS;
BEGIN
IF (LO<HI) THEN BEGIN
I:=LO;
J:=HI;
PIVLINE:=LINEPOS[J];
REPEAT
WHILE (I<J)
AND (CMP(LINEPOS[I],PIVLINE,LINEBUF)<=0) DO
I:=I+1;
WHILE (J>I)
AND (CMP(LINEPOS[J],PIVLINE,LINEBUF)>=0) DO
J:=J-1;
IF(I<J) THEN
(*OUT OF ORDER PAIR*)
EXCHANGE(LINEPOS[I],LINEPOS[J])
UNTIL (I>=J);
EXCHANGE(LINEPOS[I],LINEPOS[HI]);
IF(I-LO<HI-I) THEN BEGIN
RQUICK(LO,I-1);
RQUICK(I+1,HI)
END
ELSE BEGIN
RQUICK(I+1,HI);
RQUICK(LO,I-1)
END
END
END;(*RQUICK*)
BEGIN(*QUICK*)
RQUICK(1,NLINES)
END;
PROCEDURE GNAME(N:INTEGER;VAR NAME:XSTRING);
VAR
JUNK:INTEGER;
BEGIN
NAME[1]:=ORD('S');
NAME[2]:=ORD('T');
NAME[3]:=ORD('E');
NAME[4]:=ORD('M');
NAME[5]:=ORD('P');
NAME[6]:=ENDSTR;
JUNK:=ITOC(N,NAME,XLENGTH(NAME)+1)
END;
PROCEDURE GOPEN(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
NAME:XSTRING;
I:1..MERGEORDER;
BEGIN
FOR I:=1 TO F2-F1+1 DO BEGIN
GNAME(F1+I-1,NAME);
INFILE[I]:=MUSTOPEN(NAME,IOREAD)
END
END;
PROCEDURE GREMOVE(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
NAME:XSTRING;
I:1..MERGEORDER;
BEGIN
FOR I:= 1 TO F2-F1+1 DO BEGIN
XCLOSE(INFILE[I]);
GNAME(F1+I-1,NAME);
REMOVE(NAME)
END
END;
FUNCTION MAKEFILE(N:INTEGER):FILEDESC;
VAR
NAME:XSTRING;
BEGIN
GNAME(N,NAME);
MAKEFILE:=MUSTCREATE(NAME,IOWRITE)
END;
PROCEDURE MERGE(VAR INFILE:FDBUF; NF:INTEGER;
OUTFILE:FILEDESC);
VAR
I,J:INTEGER;
LBP:CHARPOS;
TEMP:XSTRING;
PROCEDURE REHEAP(VAR LINEPOS:POSBUF;NF:POS;
VAR LINEBUF:CHARBUF);
VAR
I,J:INTEGER;
BEGIN
I:=1;
J:=2*I;
WHILE(J<=NF)DO BEGIN
IF(J<NF) THEN
IF(CMP(LINEPOS[J],LINEPOS[J+1],LINEBUF)>0)THEN
J:=J+1;
IF(CMP(LINEPOS[I],LINEPOS[J],LINEBUF)<=0)THEN
I:=NF
ELSE
EXCHANGE(LINEPOS[I],LINEPOS[J]);(*PERCOLATE*)
I:=J;
J:=2*I
END
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;
BEGIN(*MERGE*)
J:=0;
FOR I:=1 TO NF DO
IF(GETLINE(TEMP,INFILE[I],MAXSTR)) THEN BEGIN
LBP:=(I-1)*MAXSTR+1;
SCCOPY(TEMP,LINEBUF,LBP);
LINEPOS[I]:=LBP;
J:=J+1
END;
NF:=J;
QUICK(LINEPOS,NF,LINEBUF);
WHILE (NF>0) DO BEGIN
LBP:=LINEPOS[1];
CSCOPY(LINEBUF,LBP,TEMP);
PUTSTR(TEMP,OUTFILE);
I:=LBP DIV MAXSTR +1;
IF (GETLINE(TEMP,INFILE[I],MAXSTR))THEN
SCCOPY(TEMP,LINEBUF,LBP)
ELSE BEGIN
LINEPOS[1]:=LINEPOS[NF];
NF:=NF-1
END;
REHEAP(LINEPOS,NF,LINEBUF)
END
END;
BEGIN
HIGH:=0;
REPEAT (*INITIAL FORMTION OF RUNS*)
DONE:=GTEXT(LINEPOS,NLINES,LINEBUF,STDIN);
QUICK(LINEPOS,NLINES,LINEBUF);
HIGH:=HIGH+1;
OUTFILE:=MAKEFILE(HIGH);
PTEXT(LINEPOS,NLINES,LINEBUF,OUTFILE);
XCLOSE(OUTFILE)
UNTIL (DONE);
LOW:=1;
WHILE (LOW<HIGH) DO BEGIN
LIM:=MIN(LOW+MERGEORDER-1,HIGH);
GOPEN(INFILE,LOW,LIM);
HIGH:=HIGH+1;
OUTFILE:=MAKEFILE(HIGH);
MERGE(INFILE,LIM-LOW+1,OUTFILE);
XCLOSE(OUTFILE);
GREMOVE(INFILE,LOW,LIM);
LOW:=LOW+MERGEORDER
END;
GNAME(HIGH,NAME);
OUTFILE:=OPEN(NAME,IOREAD);
FCOPY(OUTFILE,STDOUT);
XCLOSE(OUTFILE);
REMOVE(NAME)
END;
PROCEDURE UNIQUE;
VAR
BUF:ARRAY[0..1] OF XSTRING;
CUR:0..1;
BEGIN
CUR:=1;
BUF[1-CUR][1]:=ENDSTR;
WHILE (GETLINE(BUF[CUR],STDIN,MAXSTR))DO
IF (NOT EQUAL (BUF[CUR],BUF[1-CUR])) THEN BEGIN
PUTSTR(BUF[CUR],STDOUT);
CUR:=1-CUR
END
END;
PROCEDURE KWIC;
CONST
FOLD=DOLLAR;
VAR
BUF:XSTRING;
PROCEDURE PUTROT(VAR BUF:XSTRING);
VAR I:INTEGER;
PROCEDURE ROTATE(VAR BUF:XSTRING;N:INTEGER);
VAR I:INTEGER;
BEGIN
I:=N;
WHILE (BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
PUTC(BUF[I]);
I:=I+1
END;
PUTC(FOLD);
FOR I:=1 TO N-1 DO
PUTC(BUF[I]);
PUTC(NEWLINE)
END;(*ROTATE*)
BEGIN(*PUTROT*)
I:=1;
WHILE(BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
IF (ISALPHANUM(BUF[I])) THEN BEGIN
ROTATE(BUF,I);(*TOKEN STATRS AT "I"*)
REPEAT
I:=I+1
UNTIL (NOT ISALPHANUM(BUF[I]))
END;
I:=I+1
END
END;(*PUTROT*)
BEGIN(*KWIC*)
WHILE(GETLINE(BUF,STDIN,MAXSTR))DO
PUTROT(BUF)
END;
PROCEDURE UNROTATE;
CONST
MAXOUT=80;
MIDDLE=40;
FOLD=DOLLAR;
VAR
INBUF,OUTBUF:XSTRING;
I,J,F:INTEGER;
BEGIN
WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO BEGIN
FOR I:=1 TO MAXOUT-1 DO
OUTBUF[I]:=BLANK;
F:=INDEX(INBUF,FOLD);
J:=MIDDLE-1;
FOR I:=XLENGTH(INBUF)-1 DOWNTO F+1 DO BEGIN
OUTBUF[J]:=INBUF[I];
J:=J-1;
IF(J<=0)THEN
J:=MAXOUT-1
END;
J:=MIDDLE+1;
FOR I:=1 TO F-1 DO BEGIN
OUTBUF[J]:=INBUF[I];
J:=J MOD (MAXOUT-1) +1
END;
FOR J:=1 TO MAXOUT-1 DO
IF(OUTBUF[J]<>BLANK) THEN
I:=J;
OUTBUF[I+1]:=ENDSTR;
PUTSTR(OUTBUF,STDOUT);
PUTC(NEWLINE)
END
END;
SHAR_EOF
if test 7602 -ne "`wc -c < 'chapter4.pas'`"
then
echo shar: error transmitting "'chapter4.pas'" '(should have been 7602 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0