Software Tools in Turbo Pascal (Part 1 of 2)
sources-request at panda.UUCP
sources-request at panda.UUCP
Sun Nov 3 22:29:19 AEST 1985
Mod.sources: Volume 3, Issue 33
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:
# README.V30
# shell.pas
# initcmd.pas
# toolu.pas
# fprims.pas
# chapter7.pas
# chapter8.pas
# This archive created: Fri Nov 1 20:11:30 1985
export PATH; PATH=/bin:$PATH
echo shar: extracting "'README.V30'" '(3049 characters)'
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
echo shar: extracting "'shell.pas'" '(2201 characters)'
if test -f 'shell.pas'
then
echo shar: will not over-write existing file "'shell.pas'"
else
cat << \SHAR_EOF > 'shell.pas'
{shell.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
PROGRAM TOOLS;
{$I TOOLU.PAS}
{$I INITCMD.PAS}
{$I CHAPTER1.PAS}
{$I CHAPTER2.PAS}
{$I CHAPTER3.PAS}
{$I CHAPTER4.PAS}
{$I CHAPTER5.PAS}
{$I CHAPTER6.PAS}
{$I CHAPTER7.PAS}
{$I CHAPTER8.PAS}
VAR
STR,STR1:STRING80;
COMMAND:XSTRING;
DONE:BOOLEAN;
I:INTEGER;
BEGIN {SHELL}
DONE:=FALSE;
WHILE NOT DONE
DO
BEGIN
INITCMD;
IF GETARG(1,COMMAND,MAXSTR)
THEN
BEGIN
STR:='';
STR1:='X';
FOR I:=1 TO XLENGTH(COMMAND)
DO
BEGIN
if COMMAND[I]in[97..122]
then
str1[1]:=chr(command[i]-32)
ELSE STR1[1]:=chr(COMMAND[I]);
STR:=CONCAT(STR,e if str = 'ENTAB' then entab
else if str = 'OVERSTRIKE' then overstrike
else if str = 'COMPRESS' then compress
else if str = 'EXPAND' then expand
else if str = 'ECHO' then echo
else if str = 'TRANSLIT' then translit
else if str = 'COMPARE' then compare
else if str = 'INCLUDE' then include
else if str = 'CONCAT' then concat
else if str = 'PRINT' then print
else if str = 'MAKECOPY' then makecopy
else if str = 'ARCHIVE' then archive
else if str = 'SORT' then sort
else if str = 'UNIQUE' then unique
else if str = 'EDIT' then edit
else if str = 'FORMAT' then format
else if str = 'DEFINE' then macro
else if str = 'MACRO' then macro
else if str = 'QUIT' then halt
ELSE
BEGIN
WRITELN('?');
DONE:=FALSE
END
END;
endcmd;
END;
END.
SHAR_EOF
if test 2201 -ne "`wc -c < 'shell.pas'`"
then
echo shar: error transmitting "'shell.pas'" '(should have been 2201 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'initcmd.pas'" '(2249 characters)'
if test -f 'initcmd.pas'
then
echo shar: will not over-write existing file "'initcmd.pas'"
else
cat << \SHAR_EOF > 'initcmd.pas'
{initcmd.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
PROCEDURE INITCMD;
VAR
FD:FILEDESC;
FNAME:XSTRING;
FT:FILTYP;
IDX:1..MAXSTR;
I,JSKIP:INTEGER;
JUNK:BOOLEAN;
BEGIN
CMDFIL[STDIN]:=STDIO;
CMDFIL[STDOUT]:=STDIO;
CMDFIL[STDERR]:=STDIO;
FOR FD:=SUCC(STDERR) TO MAXOPEN DO
CMDFIL[FD]:=CLOSED;
WRITELN;
write('$ ');
FOR FT:= FIL1 TO FIL4 DO
CMDOPEN[FT]:=FALSE;
KBDN:=0;
if (not getline(cmdlin,STDIN,MAXSTR)) then error('NO CMDLINE');
CMDARGS:=0;
JSKIP:=0;
IDX:=1;
WHILE ((CMDLIN[IDX]<>ENDSTR)
AND(CMDLIN[IDX]<>NEWLINE)) DO BEGIN
WHILE((CMDLIN[IDX]=BLANK)AND(JSKIP MOD 2 <>1))DO
IDX:=IDX+1;
IF(CMDLIN[IDX]<>NEWLINE) THEN BEGIN
CMDARGS:=CMDARGS+1;
CMDIDX[CMDARGS]:=IDX-JSKIP;
WHILE((CMDLIN[IDX]<>NEWLINE)AND
((CMDLIN[IDX]<>BLANK)OR(JSKIP MOD 2 <>0)))DO BEGIN
IF (CMDLIN[IDX]=DQUOTE)THEN BEGIN
JSKIP:=JSKIP+1;
IDX:=IDX+1
END
ELSE BEGIN
CMDLIN[IDX-JSKIP]:=CMDLIN[IDX];
IDX:=IDX+1
END
END;
CMDLIN[IDX-JSKIP]:=ENDSTR;
IDX:=IDX+1;
IF (CMDLIN[CMDIDX[CMDARGS]]=LESS) THEN BEGIN
XCLOSE(STDIN);
CMDIDX[CMDARGS]:=CMDIDX[CMDARGS]+1;
JUNK:=GETARG(CMDARGS,FNAME,MAXSTR);
FD:=MUSTOPEN(FNAME,IOREAD);
CMDARGS:=CMDARGS-1;
END
ELSE IF (CMDLIN[CMDIDX[CMDARGS]]=GREATER) THEN BEGIN
XCLOSE(STDOUT);
CMDIDX[CMDARGS]:=CMDIDX[CMDARGS]+1;
JUNK:=GETARG(CMDARGS,FNAME,MAXSTR);
FD:=MUSTCREATE(FNAME,IOWRITE);
CMDARGS:=CMDARGS-1;
END
END
END;
END;
SHAR_EOF
if test 2249 -ne "`wc -c < 'initcmd.pas'`"
then
echo shar: error transmitting "'initcmd.pas'" '(should have been 2249 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'toolu.pas'" '(12173 characters)'
if test -f 'toolu.pas'
then
echo shar: will not over-write existing file "'toolu.pas'"
else
cat << \SHAR_EOF > 'toolu.pas'
{toolu.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
CONST
IOERROR=0;
STDIN=1;
STDOUT=2;
STDERR=3;
(*IO RELEATED STUFF*)
MAXOPEN=7;
IOREAD=0;
IOWRITE=1;
MAXCMD=20;
ENDFILE=255;
BLANK=32;
ENDSTR=0;
MAXSTR=100;
BACKSPACE=8;
TAB=9;
NEWLINE=10;
EXCLAM=33;
DQUOTE=34;
SHARP=35;
DOLLAR=36;
PERCENT=37;
AMPER=38;
SQUOTE=39;
ACUTE=SQUOTE;
LPAREN=40;
RPAREN=41;
STAR=42;
PLUS=43;
COMMA=44;
MINUS=45;
DASH=MINUS;
PERIOD=46;
SLASH=47;
COLON=58;
SEMICOL=59;
LESS=60;
EQUALS=61;
GREATER=62;
QUESTION=63;
ATSIGN=64;
ESCAPE=ATSIGN;
LBRACK=91;
BACKSLASH=92;
RBRACK=93;
CARET=94;
GRAVE=96;
UNDERLINE=95;
TILDE=126;
LBRACE=123;
BAR=124;
RBRACE=125;
TYPE
CHARACTER=0..255;
XSTRING=ARRAY[1..MAXSTR]OF CHARACTER;
STRING80=string[80];
FILEDESC=IOERROR..MAXOPEN;
FILTYP=(CLOSED,STDIO,FIL1,FIL2,FIL3,FIL4);
VAR
KBDN,KBDNEXT:INTEGER;
KBDLINE:XSTRING;
CMDARGS:0..MAXCMD;
CMDIDX:ARRAY[1..MAXCMD] OF 1..MAXSTR;
CMDLIN:XSTRING;
CMDLINE:STRING80;
CMDFIL:ARRAY[STDIN..MAXOPEN]OF FILTYP;
CMDOPEN:ARRAY[FILTYP]OF BOOLEAN;
FILE1,FILE2,FILE3,FILE4:TEXT;
FUNCTION GETKBD(VAR C:CHARACTER):CHARACTER;FORWARD;
FUNCTION FGETCF(VAR FIL:TEXT):CHARACTER;FORWARD;
FUNCTION GETCF(VAR C:CHARACTER;FD:FILEDESC):CHARACTER;FORWARD;
FUNCTION GETC(VAR C:CHARACTER):CHARACTER;FORWARD;
PROCEDURE FPUTCF(C:CHARACTER;VAR FIL:TEXT);FORWARD;
PROCEDURE PUTCF(C:CHARACTER;FD:FILEDESC);FORWARD;
PROCEDURE PUTC(C:CHARACTER);FORWARD;
PROCEDURE PUTDEC(N,W:INTEGER);FORWARD;
FUNCTION ITOC(N:INTEGER;VAR S:XSTRING;I:INTEGER):INTEGER;FORWARD;
FUNCTION GETARG(N:INTEGER;VAR S:XSTRING;
MAXSIZE:INTEGER):BOOLEAN;FORWARD;
PROCEDURE SCOPY(VAR SRC:XSTRING;I:INTEGER;VAR DEST:XSTRING;J:INTEGER);FORWARD;
PROCEDURE ENDCMD;FORWARD;
PROCEDURE XCLOSE(FD:FILEDESC);FORWARD;
FUNCTION MUSTCREATE(VAR NAME:XSTRING;MODE:INTEGER):
FILEDESC;FORWARD;
FUNCTION CREATE(VAR NAME:XSTRING;MODE:INTEGER):FILEDESC;FORWARD;
FUNCTION XLENGTH(VAR S:XSTRING):INTEGER;FORWARD;
PROCEDURE STRNAME(VAR STR:STRING80;VAR XSTR:XSTRING);FORWARD;
PROCEDURE ERROR(STR:STRING80);FORWARD;
FUNCTION MAX(X,Y:INTEGER):INTEGER;FORWARD;
PROCEDURE REMOVE(NAME:XSTRING);FORWARD;
FUNCTION GETLINE(VAR STR:XSTRING;FD:FILEDESC;
SIZE:INTEGER):BOOLEAN;FORWARD;
FUNCTION OPEN(VAR NAME:XSTRING;MODE:INTEGER):
FILEDESC;FORWARD;
FUNCTION FDALLOC:FILEDESC;FORWARD;
FUNCTION FTALLOC:FILTYP;FORWARD;
FUNCTION NARGS:INTEGER;FORWARD;
FUNCTION ADDSTR(C:CHARACTER;VAR OUTSET:XSTRING;
VAR J:INTEGER;MAXSET:INTEGER):BOOLEAN;FORWARD;
PROCEDURE PUTSTR(STR:XSTRING;FD:FILEDESC);FORWARD;
FUNCTION MUSTOPEN(VAR NAME:XSTRING;MODE:INTEGER):FILEDESC;FORWARD;
FUNCTION MIN(X,Y:INTEGER):INTEGER;FORWARD;
FUNCTION ISUPPER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION EQUAL(VAR STR1,STR2:XSTRING):BOOLEAN;FORWARD;
FUNCTION INDEX(VAR S:XSTRING;C:CHARACTER):INTEGER;FORWARD;
FUNCTION ISALPHANUM(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ESC(VAR S:XSTRING;VAR I:INTEGER):
CHARACTER;FORWARD;
PROCEDURE FCOPY(FIN,FOUT:FILEDESC);FORWARD;
FUNCTION CTOI(VAR S:XSTRING;VAR I:INTEGER):INTEGER;FORWARD;
FUNCTION ISDIGIT(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLOWER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISLETTER(C:CHARACTER):BOOLEAN;FORWARD;
FUNCTION ISDIGIT;
BEGIN
ISDIGIT:=C IN [ORD('0')..ORD('9')]
END;
FUNCTION ISLOWER;
BEGIN
ISLOWER:=C IN [97..122]
END;
FUNCTION ISLETTER;
BEGIN
ISLETTER:=C IN [65..90]+[97..122]
END;
FUNCTION CTOI;
VAR N,SIGN:INTEGER;
BEGIN
WHILE (S[I]=BLANK) OR (S[I]=TAB)DO
I:=I+1;
IF(S[I]=MINUS) THEN
SIGN:=-1
ELSE
SIGN:=1;
IF(S[I]=PLUS)OR(S[I]=MINUS)THEN
I:=I+1;
N:=0;
WHILE(ISDIGIT(S[I])) DO BEGIN
N:=10*N+S[I]-ORD('0');
I:=I+1
END;
CTOI:=SIGN*N
END;
PROCEDURE FCOPY;
VAR
C:CHARACTER;
BEGIN
WHILE(GETCF(C,FIN)<>ENDFILE) DO
PUTCF(C,FOUT)
END;
FUNCTION INDEX;
VAR I:INTEGER;
BEGIN
I:=1;
WHILE(S[I]<>C) AND (S[I]<>ENDSTR)DO
I:=I+1;
IF (S[I]=ENDSTR) THEN
INDEX:=0
ELSE
INDEX:=I
END;
FUNCTION ESC;
BEGIN
IF(S[I]<>ATSIGN) THEN
ESC:=S[I]
ELSE IF(S[I+1]=ENDSTR) THEN (*@ NOT SPECIAL AT END*)
ESC:=ATSIGN
ELSE BEGIN
I:=I+1;
IF(S[I]=ORD('N'))THEN ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
FUNCTION ISALPHANUM;
BEGIN
ISALPHANUM:=C IN
[ORD('A')..ORD('Z'),ORD('0')..ORD('9'),
97..122]
END;
FUNCTION MAX;
BEGIN
IF(X>Y)THEN
MAX:=X
ELSE
MAX:=Y
END;
FUNCTION MIN;
BEGIN
IF X<Y THEN
MIN:=X
ELSE
MIN:=Y
END;
FUNCTION ISUPPER;
BEGIN
ISUPPER:=C IN [ORD('A')..ORD('Z')]
END;
FUNCTION XLENGTH;
VAR
N:INTEGER;
BEGIN
N:=1;
WHILE(S[N]<>ENDSTR)DO
N:=N+1;
XLENGTH:=N-1
END;
FUNCTION GETARG;
BEGIN
IF((N<1)OR(CMDARGS<N))THEN
GETARG:=FALSE
ELSE BEGIN
SCOPY(CMDLIN,CMDIDX[N],S,1);
GETARG:=TRUE
END
END;(*GETARG*)
PROCEDURE SCOPY;
BEGIN
WHILE(SRC[I]<>ENDSTR)DO BEGIN
DEST[J]:=SRC[I];
I:=I+1;
J:=J+1
END;
DEST[J]:=ENDSTR;
END;
(*$I-*)
FUNCTION CREATE;
VAR
FD:FILEDESC;
SNM:STRING80;
BEGIN
FD:=FDALLOC;
IF(FD<>IOERROR)THEN BEGIN
STRNAME(SNM,NAME);
CASE (CMDFIL[FD])OF
FIL1:
begin assign(FILE1,SNM);rewrite(FILE1) end;
FIL2:begin assign(FILE2,SNM);rewrite(FILE2) end;
FIL3:begin assign(FILE3,SNM);rewrite(FILE3) end;
FIL4:begin assign(FILE4,SNM);rewrite(FILE4) end
END;
IF(IORESULT<>0)THEN BEGIN
XCLOSE(FD);
FD:=IOERROR
END
END;
CREATE:=FD;
END;
(*$I+*)
PROCEDURE STRNAME;
VAR I:INTEGER;
BEGIN
STR:='.PAS';
I:=1;
WHILE(XSTR[I]<>ENDSTR)DO BEGIN
INSERT('X',STR,I);
STR[I]:=CHR(XSTR[I]);
I:=I+1
END
END;
PROCEDURE ERROR;
BEGIN
WRITELN(STR);
HALT
END;
FUNCTION MUSTCREATE;
VAR
FD:FILEDESC;
BEGIN
FD:=CREATE(NAME,MODE);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
ERROR(' :CAN''T CREATE FILE')
END;
MUSTCREATE:=FD
END;
FUNCTION NARGS;
BEGIN
NARGS:=CMDARGS
END;
PROCEDURE REMOVE;
VAR
FD:FILEDESC;
BEGIN
FD:=OPEN(NAME,IOREAD);
IF(FD=IOERROR)THEN
WRITELN('CAN''T REMOVE FILE')
ELSE BEGIN
CASE (CMDFIL[FD]) OF
FIL1:CLOSE(FILE1);
FIL2:CLOSE(FILE2);
FIL3:CLOSE(FILE3);
FIL4:CLOSE(FILE4);
END
END;
CMDFIL[FD]:=CLOSED
END;
FUNCTION GETLINE;
VAR I,ii:INTEGER;
DONE:BOOLEAN;
CH:CHARACTER;
BEGIN
I:=0;
REPEAT
DONE:=TRUE;
CH:=GETCF(CH,FD);
IF(CH=ENDFILE) THEN
I:=0
ELSE IF (CH=NEWLINE) THEN BEGIN
I:=I+1;
STR[I]:=NEWLINE
END
ELSE IF (SIZE-2<=I) THEN BEGIN
WRITELN('LINE TOO LONG');
I:=I+1;
STR[I]:=NEWLINE
END
ELSE BEGIN
DONE:=FALSE;
I:=I+1;
STR[I]:=CH;
END
UNTIL(DONE);
STR[I+1]:=ENDSTR;
GETLINE:=(0<I)
END;(*GETLINE*)
(*$I-*)
FUNCTION OPEN;
VAR FD:FILEDESC;
SNM:STRING80;
BEGIN
FD:=FDALLOC;
IF(FD<>IOERROR) THEN BEGIN
STRNAME(SNM,NAME);
CASE (CMDFIL[FD]) OF
FIL1:begin assign(FILE1,SNM);RESET(FILE1) end;
FIL2:begin assign(FILE2,SNM);RESET(FILE2) end;
FIL3:begin assign(FILE3,SNM);RESET(FILE3) end;
FIL4:begin assign(FILE4,SNM);RESET(FILE4) end
END;
IF(IORESULT<>0) THEN BEGIN
XCLOSE(FD);
FD:=IOERROR
END
END;
OPEN:=FD
END;
(*$I+*)
FUNCTION FTALLOC;
VAR DONE:BOOLEAN;
FT:FILTYP;
BEGIN
FT:=FIL1;
REPEAT
DONE:=(NOT CMDOPEN[FT] OR (FT=FIL4));
IF(NOT DONE) THEN
FT:=SUCC(FT)
UNTIL (DONE);
IF(CMDOPEN[FT]) THEN
FTALLOC:=CLOSED
ELSE
FTALLOC:=FT
END;
FUNCTION FDALLOC;
VAR DONE:BOOLEAN;
FD:FILEDESC;
BEGIN
FD:=STDIN;
DONE:=FALSE;
WHILE(NOT DONE) DO
IF((CMDFIL[FD]=CLOSED) OR (FD=MAXOPEN))THEN
DONE:=TRUE
ELSE FD:=SUCC(FD);
IF(CMDFIL[FD]<>CLOSED) THEN
FDALLOC:=IOERROR
ELSE BEGIN
CMDFIL[FD]:=FTALLOC;
IF(CMDFIL[FD]=CLOSED) THEN
FDALLOC:=IOERROR
ELSE BEGIN
CMDOPEN[CMDFIL[FD]]:=TRUE;
FDALLOC:=FD
END
END
END;(*FDALLOC*)
PROCEDURE ENDCMD;
VAR FD:FILEDESC;
BEGIN
FOR FD:=STDIN TO MAXOPEN DO
XCLOSE(FD)
END;
PROCEDURE XCLOSE;
BEGIN
CASE (CMDFIL[FD])OF
CLOSED,STDIO:;
FIL1:CLOSE(FILE1);
FIL2:CLOSE(FILE2);
FIL3:CLOSE(FILE3);
FIL4:CLOSE(FILE4)
END;
CMDOPEN[CMDFIL[FD]]:=FALSE;
CMDFIL[FD]:=CLOSED
END;
FUNCTION ADDSTR;
BEGIN
IF(J>MAXSET)THEN
ADDSTR:=FALSE
ELSE BEGIN
OUTSET[J]:=C;
J:=J+1;
ADDSTR:=TRUE
END
END;
PROCEDURE PUTSTR;
VAR I:INTEGER;
BEGIN
I:=1;
WHILE(STR[I]<>ENDSTR) DO BEGIN
PUTCF(STR[I],FD);
I:=I+1
END
END;
FUNCTION MUSTOPEN;
VAR FD:FILEDESC;
BEGIN
FD:=OPEN(NAME,MODE);
IF(FD=IOERROR)THEN BEGIN
PUTSTR(NAME,STDERR);
WRITELN(': CAN''T OPEN FILE')
END;
MUSTOPEN:=FD
END;
FUNCTION GETKBD;
VAR
DONE:BOOLEAN;
i:integer;
ch:char;
BEGIN
IF (KBDN<=0)
THEN
BEGIN
KBDNEXT:=1;
DONE:=FALSE;
if (kbdn=-2)
then
begin
readln;
kbdn:=0
end
else if (kbdn<0)
then
done:=true;
WHILE(NOT DONE)
DO
BEGIN
kbdn:=kbdn+1;
DONE:=TRUE;
if (eof(TRM))
then
kbdn:=-1
else if eoln(TRM)
then
begin
kbdline[kbdn]:=NEWLINE;
readln(TRM);
end
else if (MAXSTR-1<=kbdn)
then
begin
writeln('Line too long');
kbdline[kbdn]:=newline
end
ELSE
begin
read(TRM,ch);
kbdline[kbdn]:=ord(ch);
if (ord(ch)in [0..7,9..12,14..31])
then
write('^',chr(ord(ch)+64))
else if (kbdline[kbdn]<>BACKSPACE)
then
{do nothing}
ELSE
begin
write(ch,' ',ch);
if (1<kbdn)
then
begin
kbdn:=kbdn-2;
if kbdline[kbdn+1]in[0..31]
then
write(ch,' ',ch)
end
ELSE
kbdn:=kbdn-1
end;
done:=false
end;
END
END;
reset(TRM);
IF(KBDN<=0)
THEN
C:=ENDFILE
ELSE
BEGIN
C:=KBDLINE[KBDNEXT];
KBDNEXT:=KBDNEXT+1;
if (c=NEWLINE)
then
begin
reset(TRM);
kbdn:=-2;
end
ELSE
KBDN:=KBDN-1
END;
GETKBD:=C
END;
FUNCTION FGETCF;
VAR CH:CHAR;
BEGIN
IF(EOF(FIL))THEN
FGETCF:=ENDFILE
ELSE IF(EOLN(FIL)) THEN BEGIN
READLN(FIL);
FGETCF:=NEWLINE
END
ELSE BEGIN
READ(FIL,CH);
FGETCF:=ORD(CH);
END;
END;
FUNCTION GETCF;
BEGIN
CASE(CMDFIL[FD])OF
STDIO:C:=GETKBD(C);
FIL1:C:=FGETCF(FILE1);
FIL2:C:=FGETCF(FILE2);
FIL3:C:=FGETCF(FILE3);
FIL4:C:=FGETCF(FILE4);
END;
GETCF:=C
END;
FUNCTION GETC;
BEGIN
GETC:=GETCF(C,STDIN)
END;
PROCEDURE FPUTCF;
BEGIN
IF(C=NEWLINE)THEN
WRITELN(FIL)
ELSE
WRITE(FIL,CHR(C))
END;
PROCEDURE PUTCF;
BEGIN
CASE (CMDFIL[FD]) OF
STDIO:FPUTCF(C,CON);
FIL1:FPUTCF(C,FILE1);
FIL2:FPUTCF(C,FILE2);
FIL3:FPUTCF(C,FILE3);
FIL4:FPUTCF(C,FILE4)
END
END;
PROCEDURE PUTC;
BEGIN
PUTCF(C,STDOUT);
END;
FUNCTION ITOC;
BEGIN
IF(N<0)THEN BEGIN
S[I]:=ORD('-');
ITOC:=ITOC(-N,S,I+1);
END
ELSE BEGIN
IF (N>=10)THEN
I:=ITOC(N DIV 10,S, I);
S[I]:=N MOD 10 + ORD('0');
S[I+1]:=ENDSTR;
ITOC:=I+1;
END
END;
PROCEDURE PUTDEC;
VAR I,ND:INTEGER;
S:XSTRING;
BEGIN
ND:=ITOC(N,S,1);
FOR I:=ND TO W DO
PUTC(BLANK);
FOR I:=1 TO ND-1 DO
PUTC(S[I])
END;
FUNCTION EQUAL;
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(STR1[I]=STR2[I])AND(STR1[I]<>ENDSTR) DO
I:=I+1;
EQUAL:=(STR1[I]=STR2[I])
END;
SHAR_EOF
if test 12173 -ne "`wc -c < 'toolu.pas'`"
then
echo shar: error transmitting "'toolu.pas'" '(should have been 12173 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'fprims.pas'" '(6206 characters)'
if test -f 'fprims.pas'
then
echo shar: will not over-write existing file "'fprims.pas'"
else
cat << \SHAR_EOF > 'fprims.pas'
{fprims.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
CONST
MAXPAT=MAXSTR;
CLOSIZE=1;
CLOSURE=STAR;
BOL=PERCENT;
EOL=DOLLAR;
ANY=QUESTION;
CCL=LBRACK;
CCLEND=RBRACK;
NEGATE=CARET;
NCCL=EXCLAM;
LITCHAR=67;
FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;FORWARD;
FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
VAR PAT:XSTRING; J:INTEGER):INTEGER;FORWARD;
FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;FORWARD;
FUNCTION MAKEPAT;
VAR
I,J,LASTJ,LJ:INTEGER;
DONE,JUNK:BOOLEAN;
FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
VAR
JSTART:INTEGER;
JUNK:BOOLEAN;
PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
VAR I:INTEGER; VAR DEST:XSTRING;
VAR J:INTEGER; MAXSET:INTEGER);
CONST ESCAPE=ATSIGN;
VAR K:INTEGER;
JUNK:BOOLEAN;
FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
IF(S[I]<>ESCAPE) THEN
ESC:=S[I]
ELSE IF (S[I+1]=ENDSTR) THEN
ESC:=ESCAPE
ELSE BEGIN
I:=I+1;
IF (S[I]=ORD('N')) THEN
ESC:=NEWLINE
ELSE IF (S[I]=ORD('T')) THEN
ESC:=TAB
ELSE
ESC:=S[I]
END
END;
BEGIN
WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
IF(SRC[I]=ESCAPE)THEN
JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
ELSE IF (SRC[I]<>DASH) THEN
JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
ELSE IF (ISALPHANUM(SRC[I-1]))
AND (ISALPHANUM(SRC[I+1]))
AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
JUNK:=ADDSTR(K,DEST,J,MAXSET);
I:=I+1
END
ELSE
JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
I:=I+1
END
END;
BEGIN
I:=I+1;
IF(ARG[I]=NEGATE) THEN BEGIN
JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
I:=I+1
END
ELSE
JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
JSTART:=J;
JUNK:=ADDSTR(0,PAT,J,MAXPAT);
DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
PAT[JSTART]:=J-JSTART-1;
GETCCL:=(ARG[I]=CCLEND)
END;
PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
LASTJ:INTEGER);
VAR
JP,JT:INTEGER;
JUNK:BOOLEAN;
BEGIN
FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
JT:=JP+CLOSIZE;
JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
END;
J:=J+CLOSIZE;
PAT[LASTJ]:=CLOSURE
END;
BEGIN
J:=1;
I:=START;
LASTJ:=1;
DONE:=FALSE;
WHILE(NOT DONE) AND (ARG[I]<>DELIM)
AND (ARG[I]<>ENDSTR) DO BEGIN
LJ:=J;
IF(ARG[I]=ANY) THEN
JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
ELSE IF (ARG[I]=BOL) AND (I=START) THEN
JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
ELSE IF (ARG[I]=CCL) THEN
DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
LJ:=LASTJ;
IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
DONE:=TRUE
ELSE
STCLOSE(PAT,J,LASTJ)
END
ELSE BEGIN
JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
END;
LASTJ:=LJ;
IF(NOT DONE) THEN
I:=I+1
END;
IF(DONE) OR (ARG[I]<>DELIM) THEN
MAKEPAT:=0
ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
MAKEPAT:=0
ELSE
MAKEPAT:=I
END;
FUNCTION AMATCH;
VAR I,K:INTEGER;
DONE:BOOLEAN;
FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
VAR
ADVANCE:-1..1;
FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
OFFSET:INTEGER):BOOLEAN;
VAR
I:INTEGER;
BEGIN
LOCATE:=FALSE;
I:=OFFSET+PAT[OFFSET];
WHILE(I>OFFSET) DO
IF(C=PAT[I]) THEN BEGIN
LOCATE :=TRUE;
I:=OFFSET
END
ELSE
I:=I-1
END;BEGIN
ADVANCE:=-1;
IF(LIN[I]=ENDSTR) THEN
OMATCH:=FALSE
ELSE IF (NOT( PAT[J] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN OMATCH:CAN''T HAPPEN')
ELSE
CASE PAT[J] OF
LITCHAR:
IF (LIN[I]=PAT[J+1]) THEN
ADVANCE:=1;
BOL:
IF (I=1) THEN
ADVANCE:=0;
ANY:
IF (LIN[I]<>NEWLINE) THEN
ADVANCE:=1;
EOL:
IF(LIN[I]=NEWLINE) THEN
ADVANCE:=0;
CCL:
IF(LOCATE(LIN[I],PAT,J+1)) THEN
ADVANCE:=1;
NCCL:
IF(LIN[I]<>NEWLINE)
AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
ADVANCE:=1
END;
IF(ADVANCE>=0) THEN BEGIN
I:=I+ADVANCE;
OMATCH:=TRUE
END
ELSE
OMATCH:=FALSE
END;
FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
BEGIN
IF(NOT (PAT[N] IN
[LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
ERROR('IN PATSIZE:CAN''T HAPPEN')
ELSE
CASE PAT[N] OF
LITCHAR:PATSIZE:=2;
BOL,EOL,ANY:PATSIZE:=1;
CCL,NCCL:PATSIZE:=PAT[N+1]+2;
CLOSURE:PATSIZE:=CLOSIZE
END
END;
BEGIN
DONE:=FALSE;
WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
IF(PAT[J]=CLOSURE) THEN BEGIN
J:=J+PATSIZE(PAT,J);
I:=OFFSET;
WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
IF (NOT OMATCH(LIN,I,PAT,J)) THEN
DONE:=TRUE;
DONE:=FALSE;
WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
IF(K>0) THEN
DONE:=TRUE
ELSE
I:=I-1
END;
OFFSET:=K;
DONE:=TRUE
END
ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
THEN BEGIN
OFFSET :=0;
DONE:=TRUE
END
ELSE
J:=J+PATSIZE(PAT,J);
AMATCH:=OFFSET
END;
FUNCTION MATCH;
VAR
I,POS:INTEGER;
BEGIN
POS:=0;
I:=1;
WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
POS:=AMATCH(LIN,I,PAT,1);
I:=I+1
END;
MATCH:=(POS>0)
END;
SHAR_EOF
if test 6206 -ne "`wc -c < 'fprims.pas'`"
then
echo shar: error transmitting "'fprims.pas'" '(should have been 6206 characters)'
fi
fi # end of overwriting check
echo shar: extracting "'chapter7.pas'" '(8627 characters)'
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
echo shar: extracting "'chapter8.pas'" '(12030 characters)'
if test -f 'chapter8.pas'
then
echo shar: will not over-write existing file "'chapter8.pas'"
else
cat << \SHAR_EOF > 'chapter8.pas'
{chapter8.pas}
{
Copyright (c) 1981
By: Bell Telephone Laboratories, Inc. and
Whitesmith's Ltd.,
This software is derived from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P. J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Right is hereby granted to freely distribute or duplicate this
software, providing distribution or duplication is not for profit
or other commercial gain and that this copyright notice remains
intact.
}
PROCEDURE MACRO;
CONST
BUFSIZE=1000;
MAXCHARS=500;
MAXPOS=500;
CALLSIZE=MAXPOS;
ARGSIZE=MAXPOS;
EVALSIZE=MAXCHARS;
MAXDEF=MAXSTR;
MAXTOK=MAXSTR;
HASHSIZE=53;
ARGFLAG=DOLLAR;
TYPE
CHARPOS=1..MAXCHARS;
CHARBUF=ARRAY[1..MAXCHARS]OF CHARACTER;
POSBUF=ARRAY[1..MAXPOS]OF CHARPOS;
POS=0..MAXPOS;
STTYPE=(DEFTYPE,MACTYPE,IFTYPE,SUBTYPE,
EXPRTYPE,LENTYPE,CHQTYPE);
NDPTR=^NDBLOCK;
NDBLOCK=RECORD
NAME:CHARPOS;
DEFN:CHARPOS;
KIND:STTYPE;
NEXTPTR:NDPTR
END;
VAR
BUF:ARRAY[1..BUFSIZE]OF CHARACTER;
BP:0..BUFSIZE;
HASHTAB:ARRAY[1..HASHSIZE]OF NDPTR;
NDTABLE:CHARBUF;
NEXTTAB:CHARPOS;
CALLSTK:POSBUF;
CP:POS;
TYPESTK:ARRAY[1..CALLSIZE]OF STTYPE;
PLEV:ARRAY[1..CALLSIZE]OF INTEGER;
ARGSTK:POSBUF;
AP:POS;
EVALSTK:CHARBUF;
EP:CHARPOS;
(*BUILTINS*)
DEFNAME:XSTRING;
EXPRNAME:XSTRING;
SUBNAME,IFNAME,LENNAME,CHQNAME:XSTRING;
NULL:XSTRING;
LQUOTE,RQUOTE:CHARACTER;
DEFN,TOKEN:XSTRING;
TOKTYPE:STTYPE;
T:CHARACTER;
NLPAR:INTEGER;
PROCEDURE PUTCHR(C:CHARACTER);
BEGIN
IF(CP<=0) THEN
PUTC(C)
ELSE BEGIN
IF(EP>EVALSIZE)THEN
ERROR('MACRO:EVALUATION STACK OVERFLOW');
EVALSTK[EP]:=C;
EP:=EP+1
END
END;
PROCEDURE PUTTOK(VAR S:XSTRING);
VAR
I:INTEGER;
BEGIN
I:=1;
WHILE(S[I]<>ENDSTR) DO BEGIN
PUTCHR(S[I]);
I:=I+1
END
END;
FUNCTION PUSH(EP:INTEGER;VAR ARGSTK:POSBUF;AP:INTEGER):INTEGER;
BEGIN
IF(AP>ARGSIZE)THEN
ERROR('MACRO:ARGUMENT STACK OVERFLOW');
ARGSTK[AP]:=EP;
PUSH:=AP+1
END;
PROCEDURE SCCOPY(VAR S:XSTRING;VAR CB:CHARBUF;
I:CHARPOS);
VAR J:INTEGER;
BEGIN
J:=1;
WHILE(S[J]<>ENDSTR)DO BEGIN
CB[I]:=S[J];
J:=J+1;
I:=I+1
END;
CB[I]:=ENDSTR
END;
PROCEDURE CSCOPY(VAR CB:CHARBUF;I:CHARPOS;
VAR S:XSTRING);
VAR J:INTEGER;
BEGIN
J:=1;
WHILE(CB[I]<>ENDSTR)DO BEGIN
S[J]:=CB[I];
I:=I+1;
J:=J+1
END;
S[J]:=ENDSTR
END;
PROCEDURE PUTBACK(C:CHARACTER);
BEGIN
IF(BP>=BUFSIZE)THEN
WRITELN('TOO MANY CHARACTERS PUSHED BACK');
BP:=BP+1;
BUF[BP]:=C
END;
FUNCTION GETPBC(VAR C:CHARACTER):CHARACTER;
BEGIN
IF(BP>0)THEN
C:=BUF[BP]
ELSE BEGIN
BP:=1;
BUF[BP]:=GETC(C)
END;
IF(C<>ENDFILE)THEN
BP:=BP-1;
GETPBC:=C
END;
FUNCTION GETTOK(VAR TOKEN:XSTRING;TOKSIZE:INTEGER):
CHARACTER;
VAR I:INTEGER;
DONE:BOOLEAN;
BEGIN
I:=1;
DONE:=FALSE;
WHILE(NOT DONE) AND (I<TOKSIZE) DO
IF(ISALPHANUM(GETPBC(TOKEN[I]))) THEN
I:=I+1
ELSE
DONE:=TRUE;
IF(I>=TOKSIZE)THEN
WRITELN('DEFINE:TOKEN TOO LONG');
IF(I>1) THEN BEGIN (*SOME ALPHA WAS SEEN*)
PUTBACK(TOKEN[I]);
I:=I-1
END;
(*ELSE SINGLE NON-ALPHANUMERIC*)
TOKEN[I+1]:=ENDSTR;
GETTOK:=TOKEN[1]
END;
PROCEDURE PBSTR (VAR S:XSTRING);
VAR I:INTEGER;
BEGIN
FOR I:=XLENGTH(S) DOWNTO 1 DO
PUTBACK(S[I])
END;
FUNCTION HASH(VAR NAME:XSTRING):INTEGER;
VAR
I,H:INTEGER;
BEGIN
H:=0;
FOR I:=1 TO XLENGTH(NAME) DO
H:=(3*H+NAME[I]) MOD HASHSIZE;
HASH:=H+1
END;
FUNCTION HASHFIND(VAR NAME:XSTRING):NDPTR;
VAR
P:NDPTR;
TEMPNAME:XSTRING;
FOUND:BOOLEAN;
BEGIN
FOUND:=FALSE;
P:=HASHTAB[HASH(NAME)];
WHILE (NOT FOUND) AND (P<>NIL) DO BEGIN
CSCOPY(NDTABLE,P^.NAME,TEMPNAME);
IF(EQUAL(NAME,TEMPNAME)) THEN
FOUND:=TRUE
ELSE
P:=P^.NEXTPTR
END;
HASHFIND:=P
END;
PROCEDURE INITHASH;
VAR I:1..HASHSIZE;
BEGIN
NEXTTAB:=1;
FOR I:=1 TO HASHSIZE DO
HASHTAB[I]:=NIL
END;
FUNCTION LOOKUP(VAR NAME,DEFN:XSTRING; VAR T:STTYPE)
:BOOLEAN;
VAR P:NDPTR;
BEGIN
P:=HASHFIND(NAME);
IF(P=NIL)THEN
LOOKUP:=FALSE
ELSE BEGIN
LOOKUP:=TRUE;
CSCOPY(NDTABLE,P^.DEFN,DEFN);
T:=P^.KIND
END
END;
PROCEDURE INSTALL(VAR NAME,DEFN:XSTRING;T:STTYPE);
VAR
H,DLEN,NLEN:INTEGER;
P:NDPTR;
BEGIN
NLEN:=XLENGTH(NAME)+1;
DLEN:=XLENGTH(DEFN)+1;
IF(NEXTTAB + NLEN +DLEN > MAXCHARS) THEN BEGIN
PUTSTR(NAME,STDERR);
ERROR(':TOO MANY DEFINITIONS')
END
ELSE BEGIN
H:=HASH(NAME);
NEW(P);
P^.NEXTPTR:=HASHTAB[H];
HASHTAB[H]:=P;
P^.NAME:=NEXTTAB;
SCCOPY(NAME,NDTABLE,NEXTTAB);
NEXTTAB:=NEXTTAB+NLEN;
P^.DEFN:=NEXTTAB;
SCCOPY(DEFN,NDTABLE,NEXTTAB);
NEXTTAB:=NEXTTAB+DLEN;
P^.KIND:=T
END
END;
PROCEDURE DODEF(VAR ARGSTK:POSBUF;I,J:INTEGER);
VAR
TEMP1,TEMP2 : XSTRING;
BEGIN
IF(J-I>2) THEN BEGIN
CSCOPY(EVALSTK,ARGSTK[I+2],TEMP1);
CSCOPY(EVALSTK,ARGSTK[I+3],TEMP2);
INSTALL(TEMP1,TEMP2,MACTYPE)
END
END;
PROCEDURE DOIF(VAR ARGSTK:POSBUF;I,J:INTEGER);
VAR
TEMP1,TEMP2,TEMP3:XSTRING;
BEGIN
IF(J-I>=4) THEN BEGIN
CSCOPY(EVALSTK,ARGSTK[I+2],TEMP1);
CSCOPY(EVALSTK,ARGSTK[I+3],TEMP2);
IF(EQUAL(TEMP1,TEMP2))THEN
CSCOPY(EVALSTK,ARGSTK[I+4],TEMP3)
ELSE IF (J-I>=5) THEN
CSCOPY(EVALSTK,ARGSTK[I+5],TEMP3)
ELSE
TEMP3[I]:=ENDSTR;
PBSTR(TEMP3)
END
END;
PROCEDURE PBNUM(N:INTEGER);
VAR
TEMP:XSTRING;
JUNK:INTEGER;
BEGIN
JUNK:=ITOC(N,TEMP,1);
PBSTR(TEMP)
END;
FUNCTION EXPR(VAR S:XSTRING;VAR I:INTEGER):INTEGER;FORWARD;
PROCEDURE DOEXPR(VAR ARGSTK:POSBUF;I,J:INTEGER);
VAR
JUNK:INTEGER;
TEMP:XSTRING;
BEGIN
CSCOPY(EVALSTK,ARGSTK[I+2],TEMP);
JUNK:=1;
PBNUM(EXPR(TEMP,JUNK))
END;
FUNCTION EXPR;
VAR
V:INTEGER;
T:CHARACTER;
FUNCTION GNBCHAR(VAR S:XSTRING;VAR I:INTEGER):CHARACTER;
BEGIN
WHILE(S[I]IN[BLANK,TAB,NEWLINE])DO
I:=I+1;
GNBCHAR:=S[I]
END;
FUNCTION TERM(VAR S:XSTRING;VAR I:INTEGER):INTEGER;
VAR
V:INTEGER;
T:CHARACTER;
FUNCTION FACTOR (VAR S:XSTRING;VAR I:INTEGER):
INTEGER;
BEGIN
IF(GNBCHAR(S,I)=LPAREN) THEN BEGIN
I:=I+1;
FACTOR:=EXPR(S,I);
IF(GNBCHAR(S,I)=RPAREN) THEN
I:=I+1
ELSE
WRITELN('MACRO:MISSING PAREN IN EXPR')
END
ELSE
FACTOR:=CTOI(S,I)
END;(*FACTOR*)
BEGIN(*TERM*)
V:=FACTOR(S,I);
T:=GNBCHAR(S,I);
WHILE(T IN [STAR,SLASH,PERCENT]) DO BEGIN
I:=I+1;
CASE T OF
STAR:V:=V*FACTOR(S,I);
SLASH:
V:=V DIV FACTOR(S,I);
PERCENT:
V:=V MOD FACTOR(S,I)
END;
T:=GNBCHAR(S,I)
END;
TERM:=V
END;(*TERM*)
BEGIN(*EXPR*)
V:=TERM(S,I);
T:=GNBCHAR(S,I);
WHILE(T IN [PLUS,MINUS])DO BEGIN
I:=I+1;
IF(T IN [PLUS]) THEN
V:=V+TERM(S,I)
ELSE(*MINUS*)
V:=V-TERM(S,I);
T:=GNBCHAR(S,I)
END;
EXPR:=V
END;
PROCEDURE DOLEN(VAR ARGSTK:POSBUF;I,J:INTEGER);
VAR
TEMP:XSTRING;
BEGIN
IF(J-I>1)THEN BEGIN
CSCOPY(EVALSTK,ARGSTK[I+2],TEMP);
PBNUM(XLENGTH(TEMP))
END
ELSE
PBNUM(0)
END;
PROCEDURE DOSUB(VAR ARGSTK:POSBUF;I,J:INTEGER);
VAR
AP,FC,K,NC:INTEGER;
TEMP1,TEMP2:XSTRING;
BEGIN
IF(J-I>=3) THEN BEGIN
IF(J-I<4) THEN
NC:=MAXTOK
ELSE BEGIN
CSCOPY(EVALSTK,ARGSTK[I+4],TEMP1);
K:=1;
NC:=EXPR(TEMP1,K)
END;
CSCOPY(EVALSTK,ARGSTK[I+3],TEMP1);
AP:=ARGSTK[I+2];
K:=1;
FC:=AP+EXPR(TEMP1,K)-1;
CSCOPY(EVALSTK,AP,TEMP2);
IF(FC>=AP) AND (FC<AP+XLENGTH(TEMP2)) THEN BEGIN
CSCOPY(EVALSTK,FC,TEMP1);
FOR K:=FC+MIN(NC,XLENGTH(TEMP1))-1 DOWNTO FC DO
PUTBACK(EVALSTK[K])
END
END
END;
PROCEDURE DOCHQ(VAR ARGSTK:POSBUF;I,J:INTEGER);
VAR
TEMP:XSTRING;
N:INTEGER;
BEGIN
CSCOPY(EVALSTK,ARGSTK[I+2],TEMP);
N:=XLENGTH(TEMP);
IF(N<=0)THEN BEGIN
LQUOTE:=ORD(LESS);
RQUOTE:=ORD(GREATER)
END
ELSE IF (N=1) THEN BEGIN
LQUOTE:=TEMP[1];
RQUOTE:=LQUOTE
END
ELSE BEGIN
LQUOTE:=TEMP[1];
RQUOTE:=TEMP[2]
END
END;
PROCEDURE EVAL(VAR ARGSTK:POSBUF;TD:STTYPE;
I,J:INTEGER);
VAR
ARGNO,K,T:INTEGER;
TEMP:XSTRING;
BEGIN
T:=ARGSTK[I];
IF(TD=DEFTYPE)THEN
DODEF(ARGSTK,I,J)
ELSE IF (TD=EXPRTYPE)THEN
DOEXPR(ARGSTK,I,J)
ELSE IF (TD=SUBTYPE) THEN
DOSUB(ARGSTK,I,J)
ELSE IF (TD=IFTYPE) THEN
DOIF(ARGSTK,I,J)
ELSE IF (TD=LENTYPE) THEN
DOLEN(ARGSTK,I,J)
ELSE IF (TD=CHQTYPE) THEN
DOCHQ(ARGSTK,I,J)
ELSE BEGIN
K:=T;
WHILE(EVALSTK[K]<>ENDSTR) DO
K:=K+1;
K:=K-1;
WHILE(K>T) DO BEGIN
IF(EVALSTK[K-1] <> ARGFLAG) THEN
PUTBACK(EVALSTK[K])
ELSE BEGIN
ARGNO:=ORD(EVALSTK[K])-ORD('0');
IF(ARGNO>=0) AND (ARGNO <J-I)THEN BEGIN
CSCOPY(EVALSTK,ARGSTK[I+ARGNO+1],TEMP);
PBSTR(TEMP)
END;
K:=K-1
END;
K:=K-1
END;
IF(K=T)THEN
PUTBACK(EVALSTK[K])
END
END;
PROCEDURE INITMACRO;
BEGIN
NULL[1]:=ENDSTR;
DEFNAME[1]:=ORD('d');
DEFNAME[2]:=ORD('e');
DEFNAME[3]:=ORD('f');
DEFNAME[4]:=ORD('i');
DEFNAME[5]:=ORD('n');
DEFNAME[6]:=ORD('e');
DEFNAME[7]:=ENDSTR;
SUBNAME[1]:=ORD('s');
SUBNAME[2]:=ORD('u');
SUBNAME[3]:=ORD('b');
SUBNAME[4]:=ORD('s');
SUBNAME[5]:=ORD('t');
SUBNAME[6]:=ORD('r');
SUBNAME[7]:=ENDSTR;
EXPRNAME[1]:=ORD('e');
EXPRNAME[2]:=ORD('x');
EXPRNAME[3]:=ORD('p');
EXPRNAME[4]:=ORD('r');
EXPRNAME[5]:=ENDSTR;
IFNAME[1]:=ORD('i');
IFNAME[2]:=ORD('f');
IFNAME[3]:=ORD('e');
IFNAME[4]:=ORD('l');
IFNAME[5]:=ORD('s');
IFNAME[6]:=ORD('e');
IFNAME[7]:=ENDSTR;
LENNAME[1]:=ORD('l');
LENNAME[2]:=ORD('e');
LENNAME[3]:=ORD('n');
LENNAME[4]:=ENDSTR;
CHQNAME[1]:=ORD('c');
CHQNAME[2]:=ORD('h');
CHQNAME[3]:=ORD('a');
CHQNAME[4]:=ORD('n');
CHQNAME[5]:=ORD('g');
CHQNAME[6]:=ORD('e');
CHQNAME[7]:=ORD('q');
CHQNAME[8]:=ENDSTR;
BP:=0;
INITHASH;
LQUOTE:=ORD('`');
RQUOTE:=ORD('''')
END;
BEGIN
INITMACRO;
INSTALL(DEFNAME,NULL,DEFTYPE);
INSTALL(EXPRNAME,NULL,EXPRTYPE);
INSTALL(SUBNAME,NULL,SUBTYPE);
INSTALL(IFNAME,NULL,IFTYPE);
INSTALL(LENNAME,NULL,LENTYPE);
INSTALL(CHQNAME,NULL,CHQTYPE);
CP:=0;AP:=1;EP:=1;
WHILE(GETTOK(TOKEN,MAXTOK)<>ENDFILE)DO
IF(ISLETTER(TOKEN[1]))THEN BEGIN
IF(NOT LOOKUP(TOKEN,DEFN,TOKTYPE))THEN
PUTTOK(TOKEN)
ELSE BEGIN
CP:=CP+1;
IF(CP>CALLSIZE)THEN
ERROR('MACRO:CALL STACK OVERFLOW');
CALLSTK[CP]:=AP;
TYPESTK[CP]:=TOKTYPE;
AP:=PUSH(EP,ARGSTK,AP);
PUTTOK(DEFN);
PUTCHR(ENDSTR);
AP:=PUSH(EP,ARGSTK,AP);
PUTTOK(TOKEN);
PUTCHR(ENDSTR);
AP:=PUSH(EP,ARGSTK,AP);
T:=GETTOK(TOKEN,MAXTOK);
PBSTR(TOKEN);
IF(T<>LPAREN)THEN BEGIN
PUTBACK(RPAREN);
PUTBACK(LPAREN)
END;
PLEV[CP]:=0
END
END
ELSE IF(TOKEN[1]=LQUOTE) THEN BEGIN
NLPAR:=1;
REPEAT
T:=GETTOK(TOKEN,MAXTOK);
IF(T=RQUOTE)THEN
NLPAR:=NLPAR-1
ELSE IF (T=LQUOTE)THEN
NLPAR:=NLPAR+1
ELSE IF (T=ENDFILE) THEN
ERROR('MACRO:MISSING RIGHT QUOTE');
IF(NLPAR>0) THEN
PUTTOK(TOKEN)
UNTIL(NLPAR=0)
END
ELSE IF (CP=0)THEN
PUTTOK(TOKEN)
ELSE IF (TOKEN[1]=LPAREN) THEN BEGIN
IF(PLEV[CP]>0)THEN
PUTTOK(TOKEN);
PLEV[CP]:=PLEV[CP]+1
END
ELSE IF (TOKEN[1]=RPAREN)THEN BEGIN
PLEV[CP]:=PLEV[CP]-1;
IF(PLEV[CP]>0)THEN
PUTTOK(TOKEN)
ELSE BEGIN
PUTCHR(ENDSTR);
EVAL(ARGSTK,TYPESTK[CP],CALLSTK[CP],AP-1);
AP:=CALLSTK[CP];
EP:=ARGSTK[AP];
CP:=CP-1
END
END
ELSE IF (TOKEN[1]=COMMA) AND (PLEV[CP]=1)THEN BEGIN
PUTCHR(ENDSTR);
AP:=PUSH(EP,ARGSTK,AP)
END
ELSE
PUTTOK(TOKEN);
IF(CP<>0)THEN
ERROR('MACRO:UNEXPECTED END OF INPUT')
END;
SHAR_EOF
if test 12030 -ne "`wc -c < 'chapter8.pas'`"
then
echo shar: error transmitting "'chapter8.pas'" '(should have been 12030 characters)'
fi
fi # end of overwriting check
# End of shell archive
exit 0
More information about the Mod.sources
mailing list