Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site seismo.CSS.GOV Posting-Version: version B 2.10.2 9/3/84; site panda.UUCP Path: seismo!harvard!talcott!panda!sources-request From: sources-request@panda.UUCP Newsgroups: mod.sources Subject: Software Tools in Turbo Pascal (Part 1 of 2) Message-ID: <1059@panda.UUCP> Date: 3 Nov 85 12:29:19 GMT Sender: jpn@panda.UUCP Lines: 2368 Approved: jpn@panda.UUCP 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 XENDSTR)DO N:=N+1; XLENGTH:=N-1 END; FUNCTION GETARG; BEGIN IF((N<1)OR(CMDARGSENDSTR)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:=(0IOERROR) 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=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(I0) 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 (J0) 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)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 (FCENDSTR) 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 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