Software Tools in Pascal for Turbo Pascal (part 1/2)
reintom at rocky2.UUCP
reintom at rocky2.UUCP
Wed Jul 16 15:01:18 AEST 1986
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# 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 0
More information about the Comp.sources.unix
mailing list