Software Tools in Pascal for Turbo Pascal (part 2/3)
Tom Reingold
reintom at rocky2.UUCP
Fri Sep 19 15:15:35 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:
# chapter5.pas
# chapter6.pas
# chapter7.pas
# This archive created: Thu Sep 18 14:27:33 1986
export PATH; PATH=/bin:$PATH
if test -f 'chapter5.pas'
then
echo shar: will not over-write existing file "'chapter5.pas'"
else
cat << \SHAR_EOF > 'chapter5.pas'
{chapter5.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
CONST
MAXPAT=MAXSTR;
CLOSIZE=1;
CLOSURE=STAR;
BOL=PERCENT;
EOL=DOLLAR;
ANY=QUESTION;
CCL=LBRACK;
CCLEND=RBRACK;
NEGATE=CARET;
NCCL=EXCLAM;
LITCHAR=67;
FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;FORWARD;
FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
VAR PAT:XSTRING; J:INTEGER):INTEGER;FORWARD;
FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;FORWARD;
FUNCTION MAKEPAT;
VAR
I,J,LASTJ,LJ:INTEGER;
DONE,JUNK:BOOLEAN;
FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
VAR
JSTART:INTEGER;
JUNK:BOOLEAN;
PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
VAR I:INTEGER; VAR DEST:XSTRING;
VAR J:INTEGER; MAXSET:INTEGER);
CONST ESCAPE=ATSIGN;
VAR K:INTEGER;
JUNK:BOOLEAN;
FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
IF(S[I]<>ESCAPE) THEN
ESC:=S[I]
ELSE IF (S[I+1]=ENDSTR) THEN
ESC:=ESCAPE
ELSE BEGIN
I:=I+1;
IF (S[I]=ORD('N')) THEN
ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
BEGIN
WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
IF(SRC[I]=ESCAPE)THEN
JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
ELSE IF (SRC[I]<>DASH) THEN
JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
ELSE IF (ISALPHANUM(SRC[I-1]))
AND (ISALPHANUM(SRC[I+1]))
AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
JUNK:=ADDSTR(K,DEST,J,MAXSET);
I:=I+1
END
ELSE
JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
I:=I+1
END
END;
BEGIN
I:=I+1;
IF(ARG[I]=NEGATE) THEN BEGIN
JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
I:=I+1
END
ELSE
JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
JSTART:=J;
JUNK:=ADDSTR(0,PAT,J,MAXPAT);
DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
PAT[JSTART]:=J-JSTART-1;
GETCCL:=(ARG[I]=CCLEND)
END;
PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
LASTJ:INTEGER);
VAR
JP,JT:INTEGER;
JUNK:BOOLEAN;
BEGIN
FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
JT:=JP+CLOSIZE;
JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
END;
J:=J+CLOSIZE;
PAT[LASTJ]:=CLOSURE
END;
BEGIN
J:=1;
I:=START;
LASTJ:=1;
DONE:=FALSE;
WHILE(NOT DONE) AND (ARG[I]<>DELIM)
AND (ARG[I]<>ENDSTR) DO BEGIN
LJ:=J;
IF(ARG[I]=ANY) THEN
JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
ELSE IF (ARG[I]=BOL) AND (I=START) THEN
JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=CCL) THEN
DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
LJ:=LASTJ;
IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
DONE:=TRUE
ELSE
STCLOSE(PAT,J,LASTJ)
END
ELSE BEGIN
JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
END;
LASTJ:=LJ;
IF(NOT DONE) THEN
I:=I+1
END;
IF(DONE) OR (ARG[I]<>DELIM) THEN
MAKEPAT:=0
ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
MAKEPAT:=0
ELSE
MAKEPAT:=I
END;
FUNCTION AMATCH;
VAR I,K:INTEGER;
DONE:BOOLEAN;
FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
VAR
ADVANCE:-1..1;
FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
OFFSET:INTEGER):BOOLEAN;
VAR
I:INTEGER;
BEGIN
LOCATE:=FALSE;
I:=OFFSET+PAT[OFFSET];
WHILE(I>OFFSET) DO
IF(C=PAT[I]) THEN BEGIN
LOCATE :=TRUE;
I:=OFFSET
END
ELSE
I:=I-1
END;BEGIN
ADVANCE:=-1;
IF(LIN[I]=ENDSTR) THEN
OMATCH:=FALSE
ELSE IF (NOT( PAT[J] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN OMATCH:CAN''T HAPPEN')
ELSE
CASE PAT[J] OF
LITCHAR:
IF (LIN[I]=PAT[J+1]) THEN
ADVANCE:=1;
BOL:
IF (I=1) THEN
ADVANCE:=0;
ANY:
IF (LIN[I]<>NEWLINE) THEN
ADVANCE:=1;
EOL:
IF(LIN[I]=NEWLINE) THEN
ADVANCE:=0;
CCL:
IF(LOCATE(LIN[I],PAT,J+1)) THEN
ADVANCE:=1;
NCCL:
IF(LIN[I]<>NEWLINE)
AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
ADVANCE:=1
END;
IF(ADVANCE>=0) THEN BEGIN
I:=I+ADVANCE;
OMATCH:=TRUE
END
ELSE
OMATCH:=FALSE
END;
FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
BEGIN
IF(NOT (PAT[N] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN PATSIZE:CAN''T HAPPEN')
ELSE
CASE PAT[N] OF
LITCHAR:PATSIZE:=2;
BOL,EOL,ANY:PATSIZE:=1;
CCL,NCCL:PATSIZE:=PAT[N+1]+2;
CLOSURE:PATSIZE:=CLOSIZE
END
END;
BEGIN
DONE:=FALSE;
WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
IF(PAT[J]=CLOSURE) THEN BEGIN
J:=J+PATSIZE(PAT,J);
I:=OFFSET;
WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
IF (NOT OMATCH(LIN,I,PAT,J)) THEN
DONE:=TRUE;
DONE:=FALSE;
WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
IF(K>0) THEN
DONE:=TRUE
ELSE
I:=I-1
END;
OFFSET:=K;
DONE:=TRUE
END
ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
THEN BEGIN
OFFSET :=0;
DONE:=TRUE
END
ELSE
J:=J+PATSIZE(PAT,J);
AMATCH:=OFFSET
END;
FUNCTION MATCH;
VAR
I,POS:INTEGER;
BEGIN
POS:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
POS:=AMATCH(LIN,I,PAT,1);
I:=I+1
END;
MATCH:=(POS>0)
END;
PROCEDURE FIND;
VAR
ARG,LIN,PAT:XSTRING;
FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;
BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
BEGIN
IF(NOT GETARG(2,ARG,MAXSTR))THEN
ERROR('USAGE:FIND PATTERN');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('FIND:ILLEGAL PATTERN');
WHILE(GETLINE(LIN,STDIN,MAXSTR))DO
IF (MATCH(LIN,PAT))THEN
PUTSTR(LIN,STDOUT)
END;
PROCEDURE CHANGE;
CONST
DITTO=255;
VAR
LIN,PAT,SUB,ARG:XSTRING;
FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;
BEGIN
GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
FUNCTION GETSUB(VAR ARG,SUB:XSTRING):BOOLEAN;
FUNCTION MAKESUB(VAR ARG:XSTRING; FROM:INTEGER;
DELIM:CHARACTER; VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE (ARG[I]<>DELIM) AND (ARG[I]<>ENDSTR) DO BEGIN
IF(ARG[I]=ORD('&')) THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF (ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT)) THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;
BEGIN
GETSUB:=(MAKESUB(ARG,1,ENDSTR,SUB)>0)
END;
PROCEDURE SUBLINE(VAR LIN,PAT,SUB:XSTRING);
VAR
I, LASTM, M:INTEGER;
JUNK:BOOLEAN;
PROCEDURE PUTSUB(VAR LIN:XSTRING; S1,S2:INTEGER;
VAR SUB:XSTRING);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE (SUB[I]<>ENDSTR) DO BEGIN
IF(SUB[I]=DITTO) THEN
FOR J:=S1 TO S2-1 DO
PUTC(LIN[J])
ELSE
PUTC(SUB[I]);
I:=I+1
END
END;
BEGIN
LASTM:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) DO BEGIN
M:=AMATCH(LIN,I,PAT,1);
IF (M>0) AND (LASTM<>M) THEN BEGIN
PUTSUB(LIN,I,M,SUB);
LASTM:=M
END;
IF (M=0) OR (M=I) THEN BEGIN
PUTC(LIN[I]);
I:=I+1
END
ELSE
I:=M
END
END;
BEGIN
IF(NOT GETARG(2,ARG,MAXSTR)) THEN
ERROR('USAGE:CHANGE FROM [TO]');
IF (NOT GETPAT(ARG,PAT)) THEN
ERROR('CHANGE:ILLEGAL "FROM" PATTERN');
IF (NOT GETARG(3,ARG,MAXSTR)) THEN
ARG[1]:=ENDSTR;
IF(NOT GETSUB(ARG,SUB)) THEN
ERROR('CHANGE:ILLEGAL "TO" STRING');
WHILE (GETLINE(LIN,STDIN,MAXSTR)) DO
SUBLINE(LIN,PAT,SUB)
END;
SHAR_EOF
if test 8365 -ne "`wc -c < 'chapter5.pas'`"
then
echo shar: error transmitting "'chapter5.pas'" '(should have been 8365 characters)'
fi
fi # end of overwriting check
if test -f 'chapter6.pas'
then
echo shar: will not over-write existing file "'chapter6.pas'"
else
cat << \SHAR_EOF > 'chapter6.pas'
{chapter6.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
PROCEDURE EDIT;
CONST
MAXLINES=1000;
DITTO=255;
CURLINE=PERIOD;
LASTLINE=DOLLAR;
SCAN=47;
BACKSCAN=92;
ACMD=97;
CCMD=99;
DCMD=100;
ECMD=101;
EQCMD=EQUALS;
FCMD=102;
GCMD=103;
ICMD=105;
MCMD=109;
PCMD=112;
QCMD=113;
RCMD=114;
SCMD=115;
WCMD=119;
XCMD=120;
TYPE
STCODE=(ENDDATA,ERR,OK);
BUFTYPE=RECORD
TXT:INTEGER;
MARK:BOOLEAN;
END;
VAR
EDITFID:FILE OF CHARACTER;
BUF:ARRAY[0..MAXLINES]OF BUFTYPE;
RECIN:INTEGER;
RECOUT:INTEGER;
LINE1,LINE2,NLINES,CURLN,LASTLN:INTEGER;
PAT,LIN,SAVEFILE:XSTRING;
CURSAVE,I:INTEGER;
STATUS:STCODE;
MORE:BOOLEAN;
PROCEDURE GETTXT(N:INTEGER;VAR S:XSTRING);
VAR
ch:char;JUNK:BOOLEAN;I:INTEGER;
BEGIN
IF(N=0) THEN
S[1]:=ENDSTR
ELSE BEGIN
i:=0;
SEEK(EDITFID,BUF[N].TXT);
repeat
i:=succ(i);
READ(EDITFID,s[i]);
RECIN:=RECIN+1;
until S[I]=ENDSTR;
END
END;
FUNCTION GETMARK(N:INTEGER):BOOLEAN;
BEGIN
GETMARK:=BUF[N].MARK
END;
PROCEDURE PUTMARK(N:INTEGER;M:BOOLEAN);
BEGIN
BUF[N].MARK:=M
END;
FUNCTION DOPRINT(N1,N2:INTEGER):STCODE;
VAR
I:INTEGER;
LINE:XSTRING;
BEGIN
IF(N1<=0)THEN
DOPRINT:=ERR
ELSE BEGIN
FOR I:=N1 TO N2 DO BEGIN
GETTXT(I,LINE);
PUTSTR(LINE,STDOUT)
END;
CURLN:=N2;
DOPRINT:=OK
END
END;
FUNCTION DEFAULT(DEF1,DEF2:INTEGER;
VAR STATUS:STCODE):STCODE;
BEGIN
IF(NLINES=0)THEN BEGIN
LINE1:=DEF1;
LINE2:=DEF2
END;
IF(LINE1 > LINE2)OR(LINE1 <=0)THEN
STATUS:=ERR
ELSE
STATUS:=OK;
DEFAULT:=STATUS
END;
FUNCTION PREVLN(N:INTEGER):INTEGER;
BEGIN
IF(N<=0)THEN
PREVLN:=LASTLN
ELSE
PREVLN:=N-1
END;
FUNCTION NEXTLN(N:INTEGER):INTEGER;
BEGIN
IF(N>=LASTLN)THEN
NEXTLN:=0
ELSE
NEXTLN:=N+1
END;
FUNCTION PATSCAN(WAY:CHARACTER;VAR N:INTEGER):STCODE;
VAR
DONE:BOOLEAN;
LINE:XSTRING;
BEGIN
N:=CURLN;
PATSCAN:=ERR;
DONE:=FALSE;
REPEAT
IF(WAY=SCAN)THEN
N:=NEXTLN(N)
ELSE
N:=PREVLN(N);
GETTXT(N,LINE);
IF(MATCH(LINE,PAT))THEN BEGIN
PATSCAN:=OK;
DONE:=TRUE
END
UNTIL(N=CURLN)OR(DONE)
END;
FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
IF(S[I]<>ESCAPE) THEN
ESC:=S[I]
ELSE IF (S[I+1]=ENDSTR) THEN
ESC:=ESCAPE
ELSE BEGIN
I:=I+1;
IF (S[I]=ORD('N')) THEN
ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
FUNCTION OPTPAT(VAR LIN:XSTRING;VAR I:INTEGER):STCODE;
BEGIN
IF(LIN[I]=ENDSTR)THEN
I:=0
ELSE IF(LIN[I+1]=ENDSTR)THEN
I:=0
ELSE IF(LIN[I+1]=LIN[I])THEN
I:=I+1
ELSE
I:=MAKEPAT(LIN,I+1,LIN[I],PAT);
IF(PAT[1]=ENDSTR)THEN
I:=0;
IF(I=0)THEN BEGIN
PAT[1]:=ENDSTR;
OPTPAT:=ERR
END
ELSE
OPTPAT:=OK
END;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK)OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETNUM(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
VAR STATUS:STCODE):STCODE;
BEGIN
STATUS:=OK;
SKIPBL(LIN,I);
IF(ISDIGIT(LIN[I]))THEN BEGIN
NUM:=CTOI(LIN,I);
I:=I-1
END
ELSE IF(LIN[I]=CURLINE)THEN
NUM:=CURLN
ELSE IF(LIN[I]=LASTLINE)THEN
NUM:=LASTLN
ELSE IF(LIN[I]=SCAN)OR(LIN[I]=BACKSCAN)THEN BEGIN
IF(OPTPAT(LIN,I)=ERR)THEN
STATUS:=ERR
ELSE
STATUS:=PATSCAN(LIN[I],NUM)
END
ELSE
STATUS:=ENDDATA;
IF(STATUS=OK)THEN
I:=I+1;
GETNUM:=STATUS
END;
FUNCTION GETONE(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
VAR STATUS:STCODE):STCODE;
VAR
ISTART,MUL,PNUM:INTEGER;
BEGIN
ISTART:=I;
NUM:=0;
IF(GETNUM(LIN,I,NUM,STATUS)=OK)THEN
REPEAT
SKIPBL(LIN,I);
IF(LIN[I]<>PLUS)AND(LIN[I]<>MINUS)THEN
STATUS:=ENDDATA
ELSE BEGIN
IF(LIN[I]=PLUS)THEN
MUL:=+1
ELSE
MUL:=-1;
I:=I+1;
IF(GETNUM(LIN,I,PNUM,STATUS)=OK)THEN
NUM:=NUM+MUL*PNUM;
IF(STATUS=ENDDATA)THEN
STATUS:=ERR
END
UNTIL(STATUS<>OK);
IF(NUM<0)OR(NUM > LASTLN)THEN
STATUS:=ERR;
IF(STATUS<>ERR)THEN BEGIN
IF(I<=ISTART)THEN
STATUS:=ENDDATA
ELSE
STATUS:=OK
END;
GETONE:=STATUS
END;
FUNCTION GETLIST(VAR LIN:XSTRING;VAR I:INTEGER;
VAR STATUS:STCODE):STCODE;
VAR
NUM:INTEGER;
DONE:BOOLEAN;
BEGIN
LINE2:=0;
NLINES:=0;
DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK);
WHILE(NOT DONE)DO BEGIN
LINE1:=LINE2;
LINE2:=NUM;
NLINES:=NLINES+1;
IF(LIN[I]=SEMICOL)THEN
CURLN:=NUM;
IF(LIN[I]=COMMA)OR(LIN[I]=SEMICOL)THEN BEGIN
I:=I+1;
DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK)
END
ELSE
DONE:=TRUE
END;
NLINES:=MIN(NLINES,2);
IF(NLINES=0)THEN
LINE2:=CURLN;
IF(NLINES<=1)THEN
LINE1:=LINE2;
IF(STATUS<>ERR)THEN
STATUS:=OK;
GETLIST:=STATUS
END;
PROCEDURE REVERSE(N1,N2:INTEGER);
VAR
TEMP:BUFTYPE;
BEGIN
WHILE(N1<N2)DO BEGIN
TEMP:=BUF[N1];
BUF[N1]:=BUF[N2];
BUF[N2]:=TEMP;
N1:=N1+1;
N2:=N2-1
END
END;
PROCEDURE BLKMOVE(N1,N2,N3:INTEGER);
BEGIN
IF(N3<N1-1)THEN BEGIN
REVERSE(N3+1,N1-1);
REVERSE(N1,N2);
REVERSE(N3+1,N2)
END
ELSE IF(N3>N2)THEN BEGIN
REVERSE(N1,N2);
REVERSE(N2+1,N3);
REVERSE(N1,N3)
END
END;
FUNCTION MOVE(LINE3:INTEGER):STCODE;
BEGIN
IF(LINE1<=0)OR((LINE3>=LINE1)AND(LINE3<LINE2))THEN
MOVE:=ERR
ELSE BEGIN
BLKMOVE(LINE1,LINE2,LINE3);
IF(LINE3>LINE1)THEN
CURLN:=LINE3
ELSE
CURLN:=LINE3+(LINE2-LINE1+1);
MOVE:=OK
END
END;
FUNCTION LNDELETE(N1,N2:INTEGER;VAR STATUS:STCODE):
STCODE;
BEGIN
IF(N1<=0)THEN
STATUS:=ERR
ELSE BEGIN
BLKMOVE(N1,N2,LASTLN);
LASTLN:=LASTLN-(N2-N1+1);
CURLN:=PREVLN(N1);
STATUS:=OK
END;
LNDELETE:=STATUS
END;
FUNCTION CKP(VAR LIN:XSTRING;I:INTEGER;
VAR PFLAG:BOOLEAN;VAR STATUS:STCODE):STCODE;
BEGIN
SKIPBL(LIN,I);
IF(LIN[I]=PCMD)THEN BEGIN
I:=I+1;
PFLAG:=TRUE
END
ELSE
PFLAG:=FALSE;
IF(LIN[I]=NEWLINE)THEN
STATUS:=OK
ELSE
STATUS:=ERR;
CKP:=STATUS
END;
FUNCTION PUTTXT(VAR LIN:XSTRING):STCODE;
VAR I:INTEGER;
BEGIN
PUTTXT:=ERR;
IF(LASTLN<MAXLINES) THEN BEGIN
i:=0;
seek(editfid,recout);
lastln:=lastln+1;
buf[lastln].txt:=recout;
repeat
i:=succ(i);
WRITE(EDITFID,lin[i]);
recout:=recout+1
until lin[i]=ENDSTR;
write(editfid,lin[i]);
PUTMARK(LASTLN,FALSE);
BLKMOVE(LASTLN,LASTLN,CURLN);
CURLN:=CURLN+1;
PUTTXT:=OK
END
END;
PROCEDURE SETBUF;
BEGIN
(*$I-*)
ASSIGN(EDITFID,'EDTEMP');
RESET(EDITFID);
IF (IORESULT<>0) THEN REWRITE(EDITFID);
(*$I+*)
RECOUT:=0;
RECIN:=0;
CURLN:=0;
LASTLN:=0
END;
PROCEDURE CLRBUF;
BEGIN
CLOSE(EDITFID);ERASE(EDITFID)
END;
FUNCTION APPEND(LINE:INTEGER;GLOB:BOOLEAN):STCODE;
VAR
EINLINE:XSTRING;
STAT:STCODE;
DONE:BOOLEAN;
BEGIN
IF(GLOB)THEN
STAT:=ERR
ELSE BEGIN
CURLN:=LINE;
STAT:=OK;
DONE:=FALSE;
WHILE(NOT DONE)AND(STAT=OK)DO
IF(NOT GETLINE(EINLINE,STDIN,MAXSTR))THEN
STAT:=ENDDATA
ELSE IF(EINLINE[1]=PERIOD)
AND(EINLINE[2]=NEWLINE)THEN
DONE:=TRUE
ELSE IF(PUTTXT(EINLINE)=ERR)THEN
STAT:=ERR
END;
APPEND:=STAT
END;
FUNCTION DOWRITE(N1,N2:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
I:INTEGER;
FD: FILEDESC;
LINE: XSTRING;
BEGIN
FD:=CREATE(FIL,IOWRITE);
IF(FD=IOERROR)THEN
DOWRITE:=ERR
ELSE BEGIN
FOR I:=N1 TO N2 DO BEGIN
GETTXT(I,LINE);
PUTSTR(LINE,FD)
END;
XCLOSE(FD);
PUTDEC(N2-N1+1,1);
PUTC(NEWLINE);
DOWRITE:=OK
END
END;
FUNCTION DOREAD(N:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
COUNT:INTEGER;
T:BOOLEAN;
STAT:STCODE;
FD:FILEDESC;
EINLINE:XSTRING;
BEGIN
FD:=OPEN(FIL,IOREAD);
IF(FD=IOERROR)THEN
STAT:=ERR
ELSE BEGIN
CURLN:=N;
STAT:=OK;
COUNT:=0;
REPEAT
T:=GETLINE(EINLINE,FD,MAXSTR);
IF(T)THEN BEGIN
STAT:=PUTTXT(EINLINE);
IF(STAT<>ERR)THEN
COUNT:=COUNT+1
END
UNTIL(STAT<>OK)OR(T=FALSE);
XCLOSE(FD);
PUTDEC(COUNT,1);
PUTC(NEWLINE)
END;
DOREAD:=STAT
END;
FUNCTION GETFN(VAR LIN:XSTRING;VAR I:INTEGER;
VAR FIL:XSTRING):STCODE;
VAR
K:INTEGER;
STAT:STCODE;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:
XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I]IN [BLANK,TAB,NEWLINE])DO
I:=I+1;
J:=1;
WHILE(NOT(S[I]IN [ENDSTR,BLANK,TAB,
NEWLINE]))DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR)THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
BEGIN(*GETFN*)
STAT:=ERR;
IF(LIN[I+1]=BLANK)THEN BEGIN
K:=GETWORD(LIN,I+2,FIL);
IF(K>0)THEN
IF(LIN[K]=NEWLINE)THEN
STAT:=OK
END
ELSE IF(LIN[I+1]=NEWLINE)
AND(SAVEFILE[1]<>ENDSTR)THEN BEGIN
SCOPY(SAVEFILE,1,FIL,1);
STAT:=OK;
END;
IF(STAT=OK)AND(SAVEFILE[1]=ENDSTR)THEN
SCOPY(FIL,1,SAVEFILE,1);
GETFN:=STAT
END;
PROCEDURE CATSUB(VAR LIN:XSTRING;S1,S2: INTEGER;
VAR SUB: XSTRING;VAR NEW:XSTRING;
VAR K:INTEGER;MAXNEW:INTEGER);
VAR
I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
I:=1;
WHILE(SUB[I]<>ENDSTR)DO BEGIN
IF(SUB[I]=DITTO)THEN
FOR J:=S1 TO S2-1 DO
JUNK:=ADDSTR(LIN[J],NEW,K,MAXNEW)
ELSE
JUNK:=ADDSTR(SUB[I],NEW,K,MAXNEW);
I:=I+1
END
END;
FUNCTION SUBST( VAR SUB:XSTRING;GFLAG,GLOB:BOOLEAN):STCODE;
VAR
NEW,OLD:XSTRING;
J,K,LASTM,LINE,M:INTEGER;
STAT:STCODE;
DONE,SUBBED,JUNK:BOOLEAN;
BEGIN
IF(GLOB)THEN
STAT:=OK
ELSE
STAT:=ERR;
DONE:=(LINE1<=0);
LINE:=LINE1;
WHILE(NOT DONE)AND(LINE<=LINE2)DO BEGIN
J:=1;
SUBBED:=FALSE;
GETTXT(LINE,OLD);
LASTM:=0;
K:=1;
WHILE(OLD[K]<>ENDSTR)DO BEGIN
IF(GFLAG)OR(NOT SUBBED)THEN
M:=AMATCH(OLD,K,PAT,1)
ELSE
M:=0;
IF(M>0)AND(LASTM<>M)THEN BEGIN
SUBBED:=TRUE;
CATSUB(OLD,K,M,SUB,NEW,J,MAXSTR);
LASTM:=M
END;
IF(M=0)OR(M=K)THEN BEGIN
JUNK:=ADDSTR(OLD[K],NEW,J,MAXSTR);
K:=K+1
END
ELSE
K:=M
END;
IF(SUBBED)THEN BEGIN
IF(NOT ADDSTR(ENDSTR,NEW,J,MAXSTR))THEN BEGIN
STAT:=ERR;
DONE:=TRUE
END
ELSE BEGIN
STAT:=LNDELETE(LINE,LINE,STATUS);
STAT:=PUTTXT(NEW);
LINE2:=LINE2+CURLN-LINE;
LINE:=CURLN;
IF(STAT=ERR)THEN
DONE:=TRUE
ELSE
STAT:=OK
END
END;
LINE:=LINE+1
END;
SUBST:=STAT
END;
FUNCTION MAKESUB(VAR ARG:XSTRING;FROM:INTEGER;
DELIM:CHARACTER;VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
JUNK:BOOLEAN;
BEGIN
J:=1;
I:=FROM;
WHILE(ARG[I]<>DELIM)AND(ARG[I]<>ENDSTR)DO BEGIN
IF(ARG[I]=ORD('&'))THEN
JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
ELSE
JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
I:=I+1
END;
IF(ARG[I]<>DELIM) THEN
MAKESUB:=0
ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT))THEN
MAKESUB:=0
ELSE
MAKESUB:=I
END;
FUNCTION GETRHS(VAR LIN:XSTRING;VAR I:INTEGER;
VAR SUB:XSTRING;VAR GFLAG:BOOLEAN):STCODE;
BEGIN
GETRHS:=OK;
IF(LIN[I]=ENDSTR)THEN
GETRHS:=ERR
ELSE IF(LIN[I+1]=ENDSTR)THEN
GETRHS:=ERR
ELSE BEGIN
I:=MAKESUB(LIN,I+1,LIN[I],SUB);
IF(I=0)THEN
GETRHS:=ERR
ELSE IF(LIN[I+1]=ORD('G'))THEN BEGIN
I:=I+1;
GFLAG:=TRUE
END
ELSE
GFLAG:=FALSE
END
END;
FUNCTION DOCMD(VAR LIN:XSTRING;VAR I:INTEGER;
GLOB:BOOLEAN;VAR STATUS:STCODE):STCODE;
VAR
FIL,SUB:XSTRING;
LINE3:INTEGER;
GFLAG,PFLAG:BOOLEAN;
BEGIN
PFLAG:=FALSE;
STATUS:=ERR;
IF(LIN[I]=PCMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=DOPRINT(LINE1,LINE2)
END
ELSE IF(LIN[I]=NEWLINE)THEN BEGIN
IF(NLINES=0)THEN
LINE2:=NEXTLN(CURLN);
STATUS:=DOPRINT(LINE2,LINE2)
END
ELSE IF(LIN[I]=QCMD)THEN BEGIN
IF( LIN[I+1]=NEWLINE)AND(NLINES=0)AND(NOT GLOB)THEN
STATUS:=ENDDATA
END
ELSE IF(LIN[I]=ACMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
STATUS:=APPEND(LINE2,GLOB)
END
ELSE IF(LIN[I]=CCMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
STATUS:=APPEND(PREVLN(LINE1),GLOB)
END
ELSE IF(LIN[I]=DCMD)THEN BEGIN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
IF(NEXTLN(CURLN)<>0)THEN
CURLN:=NEXTLN(CURLN)
END
ELSE IF(LIN[I]=ICMD)THEN BEGIN
IF(LIN[I+1]=NEWLINE)THEN BEGIN
IF(LINE2=0)THEN
STATUS:=APPEND(0,GLOB)
ELSE
STATUS:=APPEND(PREVLN(LINE2),GLOB)
END
END
ELSE IF(LIN[I]=EQCMD)THEN BEGIN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN BEGIN
PUTDEC(LINE2,1);
PUTC(NEWLINE)
END
END
ELSE IF(LIN[I]=MCMD)THEN BEGIN
I:=I+1;
IF(GETONE(LIN,I,LINE3,STATUS)=ENDDATA)THEN
STATUS:=ERR;
IF(STATUS =OK)THEN
IF(CKP(LIN,I,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=MOVE(LINE3)
END
ELSE IF(LIN[I]=SCMD)THEN BEGIN
I:=I+1;
IF(OPTPAT(LIN,I)=OK)THEN
IF(GETRHS(LIN,I,SUB,GFLAG)=OK)THEN
IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
STATUS:=SUBST(SUB,GFLAG,GLOB)
END
ELSE IF(LIN[I]=ECMD)THEN BEGIN
IF(NLINES =0)THEN
IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
SCOPY(FIL,1,SAVEFILE,1);
CLRBUF;
SETBUF;
STATUS:=DOREAD(0,FIL)
END
END
ELSE IF(LIN[I]=FCMD)THEN BEGIN
IF(NLINES =0)THEN
IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
SCOPY(FIL,1,SAVEFILE,1);
PUTSTR(SAVEFILE,STDOUT);
PUTC(NEWLINE);
STATUS:=OK
END
END
ELSE IF(LIN[I]=RCMD)THEN BEGIN
IF(GETFN(LIN,I,FIL)=OK)THEN
STATUS:=DOREAD(LINE2,FIL)
END
ELSE IF(LIN[I]=WCMD)THEN BEGIN
IF(GETFN(LIN,I,FIL)=OK)THEN
IF(DEFAULT(1,LASTLN,STATUS)=OK)THEN
STATUS:=DOWRITE(LINE1,LINE2,FIL)
END;
IF(STATUS =OK)AND(PFLAG)THEN
STATUS:=DOPRINT(CURLN,CURLN);
DOCMD:=STATUS
END;(*DOCMD*)
FUNCTION CKGLOB(VAR LIN: XSTRING;VAR I:INTEGER;
VAR STATUS:STCODE): STCODE;
VAR
N:INTEGER;
GFLAG:BOOLEAN;
TEMP: XSTRING;
BEGIN
IF(LIN[I]<>GCMD)AND(LIN[I]<>XCMD)THEN
STATUS:=ENDDATA
ELSE BEGIN
GFLAG:=(LIN[I]=GCMD);
I:=I+1;
IF(OPTPAT(LIN,I)=ERR)THEN
STATUS:=ERR
ELSE IF( DEFAULT(1,LASTLN,STATUS)<>ERR)THEN BEGIN
I:=I+1;
FOR N:=LINE1 TO LINE2 DO BEGIN
GETTXT(N,TEMP);
PUTMARK(N,(MATCH(TEMP,PAT)=GFLAG))
END;
FOR N:=1 TO LINE1-1 DO
PUTMARK(N,FALSE);
FOR N:=LINE2+1 TO LASTLN DO
PUTMARK(N,FALSE);
STATUS:=OK
END
END;
CKGLOB:=STATUS
END;
FUNCTION DOGLOB(VAR LIN:XSTRING;VAR I,CURSAVE:INTEGER;
VAR STATUS: STCODE):STCODE;
VAR
COUNT,ISTART,N: INTEGER;
BEGIN
STATUS:=OK;
COUNT:=0;
N:=LINE1;
ISTART:=I;
REPEAT
IF(GETMARK(N))THEN BEGIN
PUTMARK(N,FALSE);
CURLN:=N;
CURSAVE:=CURLN;
I:=ISTART;
IF(DOCMD(LIN,I,TRUE,STATUS)=OK)THEN
COUNT:=0
END
ELSE BEGIN
N:=NEXTLN(N);
COUNT:=COUNT + 1
END
UNTIL(COUNT > LASTLN)OR(STATUS <> OK);
DOGLOB:=STATUS
END;
BEGIN
SETBUF;
PAT[1]:=ENDSTR;
SAVEFILE[1]:=ENDSTR;
IF(GETARG(2,SAVEFILE,MAXSTR))THEN
IF(DOREAD(0,SAVEFILE)=ERR)THEN
WRITELN('?');
MORE:=GETLINE(LIN,STDIN,MAXSTR);
WHILE(MORE)DO BEGIN
I:=1;
CURSAVE:=CURLN;
IF(GETLIST(LIN,I,STATUS)=OK)THEN BEGIN
IF(CKGLOB(LIN,I,STATUS)=OK)THEN
STATUS:=DOGLOB(LIN,I,CURSAVE,STATUS)
ELSE IF(STATUS<>ERR)THEN
STATUS:=DOCMD(LIN,I,FALSE,STATUS)
END;
IF(STATUS=ERR)THEN BEGIN
WRITELN('?');
CURLN:=MIN(CURSAVE,LASTLN)
END
ELSE IF(STATUS=ENDDATA)THEN
MORE:=FALSE;
IF(MORE)THEN
MORE:=GETLINE(LIN,STDIN,MAXSTR)
END;
CLRBUF
END;
SHAR_EOF
if test 16451 -ne "`wc -c < 'chapter6.pas'`"
then
echo shar: error transmitting "'chapter6.pas'" '(should have been 16451 characters)'
fi
fi # end of overwriting check
if test -f 'chapter7.pas'
then
echo shar: will not over-write existing file "'chapter7.pas'"
else
cat << \SHAR_EOF > 'chapter7.pas'
{chapter7.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
PROCEDURE FORMAT;
CONST
CMD=PERIOD;
PAGENUM=SHARP;
PAGEWIDTH=60;
PAGELEN=66;
HUGE=10000;
TYPE
CMDTYPE=(BP,BR,CE,FI,FO,HE,IND,LS,NF,PL,
RM,SP,TI,UL,UNKNOWN);
VAR
CURPAGE,NEWPAGE,LINENO:INTEGER;
PLVAL,M1VAL,M2VAL,M3VAL,M4VAL:INTEGER;
BOTTOM:INTEGER;
HEADER,FOOTER:XSTRING;
FILL:BOOLEAN;
LSVAL,SPVAL,INVAL,RMVAL,TIVAL,CEVAL,ULVAL:INTEGER;
OUTP,OUTW,OUTWDS:INTEGER;
OUTBUF:XSTRING;
DIR:0..1;
INBUF:XSTRING;
PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
WHILE(S[I]=BLANK) OR(S[I]=TAB)DO
I:=I+1
END;
FUNCTION GETVAL(VAR BUF:XSTRING;VAR ARGTYPE:INTEGER):INTEGER;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
ARGTYPE:=BUF[I];
IF(ARGTYPE=PLUS) OR (ARGTYPE=MINUS) THEN
I:=I+1;
GETVAL:=CTOI(BUF,I)
END;
PROCEDURE SETPARAM(VAR PARAM:INTEGER;VAL,ARGTYPE,DEFVAL,MINVAL,MAXVAL:
INTEGER);
BEGIN
IF(ARGTYPE=NEWLINE)THEN
PARAM:=DEFVAL
ELSE IF (ARGTYPE=PLUS)THEN
PARAM:=PARAM+VAL
ELSE IF(ARGTYPE=MINUS) THEN
PARAM:=PARAM-VAL
ELSE PARAM:=VAL;
PARAM:=MIN(PARAM,MAXVAL);
PARAM:=MAX(PARAM,MINVAL)
END;
PROCEDURE SKIP(N:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO N DO
PUTC(NEWLINE)
END;
PROCEDURE PUTTL(VAR BUF:XSTRING;PAGENO:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO XLENGTH(BUF) DO
IF(BUF[I]=PAGENUM) THEN
PUTDEC(PAGENO,1)
ELSE
PUTC(BUF[I])
END;
PROCEDURE PUTFOOT;
BEGIN
SKIP(M3VAL);
IF(M4VAL>0) THEN BEGIN
PUTTL(FOOTER,CURPAGE);
SKIP(M4VAL-1)
END
END;
PROCEDURE PUTHEAD;
BEGIN
CURPAGE:=NEWPAGE;
NEWPAGE:=NEWPAGE+1;
IF(M1VAL>0)THEN BEGIN
SKIP(M1VAL-1);
PUTTL(HEADER,CURPAGE)
END;
SKIP(M2VAL);
LINENO:=M1VAL+M2VAL+1
END;
PROCEDURE PUT(VAR BUF:XSTRING);
VAR
I:INTEGER;
BEGIN
IF(LINENO<=0) OR(LINENO>BOTTOM) THEN
PUTHEAD;
FOR I:=1 TO INVAL+TIVAL DO
PUTC(BLANK);
TIVAL:=0;
PUTSTR(BUF,STDOUT);
SKIP(MIN(LSVAL-1,BOTTOM-LINENO));
LINENO:=LINENO+LSVAL;
IF(LINENO>BOTTOM)THEN PUTFOOT
END;
PROCEDURE BREAK;
BEGIN
IF(OUTP>0) THEN BEGIN
OUTBUF[OUTP]:=NEWLINE;
OUTBUF[OUTP+1]:=ENDSTR;
PUT(OUTBUF)
END;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
VAR OUT:XSTRING):INTEGER;
VAR
J:INTEGER;
BEGIN
WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
I:=I+1;
J:=1;
WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
OUT[J]:=S[I];
I:=I+1;
J:=J+1
END;
OUT[J]:=ENDSTR;
IF(S[I]=ENDSTR) THEN
GETWORD:=0
ELSE
GETWORD:=I
END;
PROCEDURE LEADBL(VAR BUF:XSTRING);
VAR I,J:INTEGER;
BEGIN
BREAK;
I:=1;
WHILE(BUF[I]=BLANK) DO
I:=I+1;
IF(BUF[I]<>NEWLINE) THEN
TIVAL:=TIVAL+I-1;
FOR J:=I TO XLENGTH(BUF)+1 DO
BUF[J-I+1]:=BUF[J]
END;
PROCEDURE GETTL(VAR BUF,TTL:XSTRING);
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(NOT(BUF[I]IN[BLANK,TAB,NEWLINE]))DO
I:=I+1;
SKIPBL(BUF,I);
IF(BUF[I]=SQUOTE) OR(BUF[I]=DQUOTE)THEN
I:=I+1;
SCOPY(BUF,I,TTL,1)
END;
PROCEDURE SPACE(N:INTEGER);
BEGIN
BREAK;
IF (LINENO<=BOTTOM) THEN BEGIN
IF(LINENO<=0)THEN
PUTHEAD;
SKIP(MIN(N,BOTTOM+1-LINENO));
LINENO:=LINENO+N;
IF(LINENO>BOTTOM) THEN
PUTFOOT
END
END;
PROCEDURE PAGE;
BEGIN
BREAK;
IF(LINENO>0) AND (LINENO<=BOTTOM) THEN BEGIN
SKIP(BOTTOM+1-LINENO);putfoot
END;
LINENO:=0
END;
FUNCTION WIDTH(VAR BUF:XSTRING):INTEGER;
VAR
I,W:INTEGER;
BEGIN
W:=0;
I:=1;
WHILE(BUF[I]<>ENDSTR) DO BEGIN
IF (BUF[I] = BACKSPACE) THEN
W:=W-1
ELSE IF (BUF[I]<>NEWLINE) THEN
W:=W+1;I:=I+1
END;
WIDTH:=W
END;
PROCEDURE SPREAD(VAR BUF:XSTRING;
OUTP,NEXTRA,OUTWDS:INTEGER);
VAR
I,J,NB,NHOLES:INTEGER;
BEGIN
IF(NEXTRA>0) AND (OUTWDS>1) THEN BEGIN
DIR:=1-DIR;
NHOLES:=OUTWDS-1;
I:=OUTP-1;
J:=MIN(MAXSTR-2,I+NEXTRA);
WHILE(I<J) DO BEGIN
BUF[J]:=BUF[I];
IF(BUF[I]=BLANK) THEN BEGIN
IF(DIR=0) THEN
NB:=(NEXTRA-1) DIV NHOLES +1
ELSE NB:=NEXTRA DIV NHOLES;
NEXTRA:=NEXTRA - NB;
NHOLES:=NHOLES-1;
WHILE(NB>0) DO BEGIN
J:=J-1;
BUF[J]:=BLANK;
NB:=NB-1
END
END;
I:=I-1;
J:=J-1
END
END
END;
PROCEDURE PUTWORD(VAR WORDBUF:XSTRING);
VAR
LAST,LLVAL,NEXTRA,W:INTEGER;
BEGIN
W:=WIDTH(WORDBUF);
LAST:=XLENGTH(WORDBUF)+OUTP+1;
LLVAL:=RMVAL-TIVAL-INVAL;
IF(OUTP>0)
AND ((OUTW+W>LLVAL) OR (LAST >=MAXSTR)) THEN BEGIN
LAST:=LAST-OUTP;
NEXTRA:=LLVAL-OUTW+1;
IF(NEXTRA >0) AND(OUTWDS>1) THEN BEGIN
SPREAD(OUTBUF,OUTP,NEXTRA,OUTWDS);
OUTP:=OUTP+NEXTRA
END;
BREAK
END;
SCOPY(WORDBUF,1,OUTBUF,OUTP+1);
OUTP:=LAST;
OUTBUF[OUTP]:=BLANK;
OUTW:=OUTW+W+1;
OUTWDS:=OUTWDS+1
END;
PROCEDURE CENTER(VAR BUF:XSTRING);
BEGIN
TIVAL:=MAX((RMVAL+TIVAL-WIDTH(BUF)) DIV 2,0)
END;
PROCEDURE UNDERLN (VAR BUF:XSTRING;SIZE:INTEGER);
VAR
I,J:INTEGER;
TBUF:XSTRING;
BEGIN
J:=1;
I:=1;
WHILE(BUF[I]<>NEWLINE) AND (J<SIZE-1)DO BEGIN
IF(ISALPHANUM(BUF[I])) THEN BEGIN
TBUF[J]:=UNDERLINE;
TBUF[J+1]:=BACKSPACE;
J:=J+2
END;
TBUF[J]:=BUF[I];
J:=J+1;
I:=I+1
END;
TBUF[J]:=NEWLINE;
TBUF[J+1]:=ENDSTR;
SCOPY(TBUF,1,BUF,1)
END;
PROCEDURE TEXT(VAR INBUF:XSTRING);
VAR
WORDBUF:XSTRING;
I:INTEGER;
BEGIN
IF(INBUF[1]=BLANK) OR (INBUF[1]=NEWLINE) THEN
LEADBL(INBUF);
IF(ULVAL>0) THEN BEGIN
UNDERLN(INBUF,MAXSTR);
ULVAL:=ULVAL-1
END;
IF(CEVAL>0)THEN BEGIN
CENTER(INBUF);
PUT(INBUF);
CEVAL:=CEVAL-1
END
ELSE IF (INBUF[1]=NEWLINE)THEN
PUT(INBUF)
ELSE IF(NOT FILL) THEN
PUT(INBUF)
ELSE BEGIN
I:=1;
REPEAT
I:=GETWORD(INBUF,I,WORDBUF);
IF(I>0)THEN
PUTWORD(WORDBUF)
UNTIL(I=0)
END
END;
PROCEDURE INITFMT;
BEGIN
FILL:=TRUE;
DIR:=0;
INVAL:=0;
RMVAL:=PAGEWIDTH;
TIVAL:=0;
LSVAL:=1;
SPVAL:=0;
CEVAL:=0;
ULVAL:=0;
LINENO:=0;
CURPAGE:=0;
NEWPAGE:=1;
PLVAL:=PAGELEN;
M1VAL:=3;M2VAL:=2;M3VAL:=2;M4VAL:=3;
BOTTOM:=PLVAL-M3VAL-M4VAL;
HEADER[1]:=NEWLINE;
HEADER[2]:=ENDSTR;
FOOTER[1]:=NEWLINE;
FOOTER[2]:=ENDSTR;
OUTP:=0;
OUTW:=0;
OUTWDS:=0
END;
FUNCTION GETCMD(VAR BUF:XSTRING):CMDTYPE;
VAR
CMD:PACKED ARRAY[1..2] OF CHAR;
BEGIN
CMD[1]:=CHR(BUF[2]);
CMD[2]:=CHR(BUF[3]);
IF(CMD='fi')THEN GETCMD:=FI
ELSE IF (CMD='nf')THEN GETCMD:=NF
ELSE IF (CMD='br')THEN GETCMD:=BR
ELSE IF (CMD='ls')THEN GETCMD:=LS
ELSE IF (CMD='bp')THEN GETCMD:=BP
ELSE IF (CMD='sp')THEN GETCMD:=SP
ELSE IF (CMD='in')THEN GETCMD:=IND
ELSE IF (CMD='rm')THEN GETCMD:=RM
ELSE IF (CMD='ce')THEN GETCMD:=CE
ELSE IF (CMD='ti')THEN GETCMD:=TI
ELSE IF (CMD='ul')THEN GETCMD:=UL
ELSE IF (CMD='he') THEN GETCMD:=HE
ELSE IF (CMD='fo') THEN GETCMD:=FO
ELSE IF (CMD='pl') THEN GETCMD:=PL
ELSE GETCMD:=UNKNOWN
END;
PROCEDURE COMMAND(VAR BUF:XSTRING);
VAR CMD:CMDTYPE;
ARGTYPE,SPVAL,VAL:INTEGER;
BEGIN
CMD:=GETCMD(BUF);
IF(CMD<>UNKNOWN)THEN
VAL:=GETVAL(BUF,ARGTYPE);
CASE CMD OF
FI:BEGIN
BREAK;
FILL:=TRUE END;
NF:BEGIN BREAK;
FILL:=FALSE END;
BR:BREAK;
LS:SETPARAM(LSVAL,VAL,ARGTYPE,1,1,HUGE);
CE:BEGIN BREAK;
SETPARAM(CEVAL,VAL,ARGTYPE,1,0,HUGE) END;
UL:SETPARAM(ULVAL,VAL,ARGTYPE,1,0,HUGE);
HE:GETTL(BUF,HEADER);
FO:GETTL(BUF,FOOTER);
BP:BEGIN PAGE;
SETPARAM(CURPAGE,VAL,ARGTYPE,CURPAGE+1,-HUGE,HUGE);
NEWPAGE:=CURPAGE END;
SP:BEGIN
SETPARAM(SPVAL,VAL,ARGTYPE,1,0,HUGE);
space(spval)
END;
IND:SETPARAM(INVAL,VAL,ARGTYPE,0,0,RMVAL-1);
RM:SETPARAM(INVAL,VAL,ARGTYPE,PAGEWIDTH,
INVAL+TIVAL+1,HUGE);
TI:BEGIN BREAK;
SETPARAM(TIVAL,VAL,ARGTYPE,0,-HUGE,RMVAL) END;
PL:BEGIN
SETPARAM(PLVAL,VAL,ARGTYPE,PAGELEN,
M1VAL+M2VAL+M3VAL+M4VAL+1,HUGE);
BOTTOM:=PLVAL-M3VAL-M4VAL END;
UNKNOWN:
END
END;
BEGIN
INITFMT;
WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO
IF(INBUF[1]=CMD) THEN
COMMAND(INBUF)
ELSE
TEXT(INBUF);
PAGE
END;
SHAR_EOF
if test 8627 -ne "`wc -c < 'chapter7.pas'`"
then
echo shar: error transmitting "'chapter7.pas'" '(should have been 8627 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0
More information about the Comp.sources.unix
mailing list