Software Tools in Turbo Pascal (Part 2 of 2)
sources-request at panda.UUCP
sources-request at panda.UUCP
Sun Nov 3 22:30:14 AEST 1985
Mod.sources: Volume 3, Issue 34
Submitted by: talcott!cmcl2!lanl!jp (James Potter)
#! /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:
# chapter1.pas
# chapter2.pas
# chapter3.pas
# chapter4.pas
# chapter5.pas
# chapter6.pas
# This archive created: Fri Nov 1 20:12:01 1985
export PATH; PATH=/bin:$PATH
echo shar: extracting "'chapter1.pas'" '(2054 characters)'
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
echo shar: extracting "'chapter2.pas'" '(6124 characters)'
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
echo shar: extracting "'chapter3.pas'" '(11306 characters)'
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
echo shar: extracting "'chapter4.pas'" '(7602 characters)'
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
echo shar: extracting "'chapter5.pas'" '(8365 characters)'
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
echo shar: extracting "'chapter6.pas'" '(16451 characters)'
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 Mod.sources
mailing list