Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!utcs!mnetor!seismo!cmcl2!rna!rocky2!reintom
From: reintom@rocky2.UUCP
Newsgroups: net.sources
Subject: Software Tools in Pascal for Turbo Pascal (part 1/2)
Message-ID: <222@rocky2.UUCP>
Date: Wed, 16-Jul-86 01:01:18 EDT
Article-I.D.: rocky2.222
Posted: Wed Jul 16 01:01:18 1986
Date-Received: Fri, 18-Jul-86 01:01:38 EDT
Organization: Rockefeller Univ., N.Y.C. 10021
Lines: 2819

#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	README.V30
#	chapter1.pas
#	chapter2.pas
#	chapter3.pas
#	chapter4.pas
#	chapter5.pas
#	chapter6.pas
# This archive created: Tue Jul 15 11:45:14 1986
export PATH; PATH=/bin:$PATH
if test -f 'README.V30'
then
	echo shar: will not over-write existing file "'README.V30'"
else
cat << \SHAR_EOF > 'README.V30'
{readme.v30}

TURBTOOL.LBR DOCUMENTATION

This library contains the source from the book
"Software Tools in Pascal" by B.W. Kernighan and
P.J. Plauger, Addison-Wesley. It has been adapted
for Turbo Pascal.

How to Implement:

  Compile SHELL.PAS with the CMD option
  Execute SHELL

Accepts redirection, but not pipes.
Bill McGee, 613-828-9130

Notes: The version using TURBO is fast enough to make
this a useful set of tools for file manipulation.

          ------Further Modifications------

The primitives in this version are basically the UCSD Pascal versions
presented in the book, with modifications for Turbo Pascal.

This version has been modified for use under Turbo Pascal v. 3.0
under CP/M-86.  There are no system dependent statements in the code
to the best of my knowledge, so it should work under MS-DOS as well.

The original version (typed in by Bill McGee) was set up for CP/M-80 and
used the CHAIN capability of Turbo Pascal.  I have eliminated that
feature in favor of using INCLUDE files.  There is not enough memory
available in a CP/M-80 system for this version, but one could modify
the include file list to eliminate unwanted features or to make more
than one version, (e.g. break out EDIT, FORMAT, and DEFINE).

There was really only one change required to the McGee's original to get
it to work with version 3.0.  A readln(TRM) had to be added in the
subroutine GETKBD.  The change to CP/M-86 required replacing all calls
to the procedure BDOS(0,0) with HALT.  This change works with the CP/M-80
version of Turbo Pascal v. 3.0 as well.  Thus, as anyone can see, all of
the hard work was done by Bill.

(Adaption to version 3.0 of Turbo Pascal by Jim Potter, (505) 662-5804.)

Please note that this is copyright software.  The following notice has
been included with each file and should not be removed.

+-------------------------------------------------------------------------+
|       Copyright (c) 1981                                                |
|       By:     Bell Telephone Laboratories, Inc. and                     |
|               Whitesmith's Ltd.,                                        |
|                                                                         |
|       This software is derived from the book                            |
|               "Software Tools in Pascal", by                            |
|               Brian W. Kernighan and P. J. Plauger                      |
|               Addison-Wesley, 1981                                      |
|               ISBN 0-201-10342-7                                        |
|                                                                         |
|       Right is hereby granted to freely distribute or duplicate this    |
|       software, providing distribution or duplication is not for profit |
|       or other commercial gain and that this copyright notice remains   |
|       intact.                                                           |
+-------------------------------------------------------------------------+

SHAR_EOF
if test 3049 -ne "`wc -c < 'README.V30'`"
then
	echo shar: error transmitting "'README.V30'" '(should have been 3049 characters)'
fi
fi # end of overwriting check
if test -f 'chapter1.pas'
then
	echo shar: will not over-write existing file "'chapter1.pas'"
else
cat << \SHAR_EOF > 'chapter1.pas'
{chapter1.pas}

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

PROCEDURE COPY;
VAR C:CHARACTER;
BEGIN
  WHILE(GETC(C)<>ENDFILE)DO
    PUTC(C)
END;


PROCEDURE CHARCOUNT;
VAR
  NC:INTEGER;
  C:CHARACTER;
BEGIN
  NC:=0;
  WHILE (GETC(C)<>ENDFILE)DO
     NC:=NC+1;
  PUTDEC(NC,1);
  PUTC(NEWLINE)
END;

PROCEDURE LINECOUNT;
VAR
  N1:INTEGER;
  C:CHARACTER;
BEGIN
  N1:=0;
  WHILE(GETC(C)<>ENDFILE)DO
    IF(C=NEWLINE)THEN
      N1:=N1+1;
  PUTDEC(N1,1);
  PUTC(NEWLINE)
END;

PROCEDURE WORDCOUNT;
VAR
  NW:INTEGER;
  C:CHARACTER;
  INWORD:BOOLEAN;
BEGIN
  NW:=0;
  INWORD:=FALSE;
  WHILE(GETC(C)<>ENDFILE)DO
    IF(C=BLANK)OR(C=NEWLINE)OR(C=TAB) THEN
      INWORD:=FALSE
    ELSE IF (NOT INWORD)THEN BEGIN
      INWORD:=TRUE;
      NW:=NW+1
    END;
  PUTDEC(NW,1);
  PUTC(NEWLINE)
END;

PROCEDURE DETAB;
CONST
  MAXLINE=1000;
TYPE
  TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
  C:CHARACTER;
  COL:INTEGER;
  TABSTOPS:TABTYPE;

FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE)
  :BOOLEAN;
BEGIN
  IF(COL>MAXLINE)THEN
    TABPOS:=TRUE
  ELSE
    TABPOS:=TABSTOPS[COL]
END;

PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
  TABSPACE=4;
VAR
  I:INTEGER;
BEGIN
  FOR I:=1 TO MAXLINE DO
    TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;

BEGIN
  SETTABS(TABSTOPS);
  COL:=1;
  WHILE(GETC(C)<>ENDFILE)DO
    IF(C=TAB)THEN
     REPEAT
      PUTC(BLANK);
      COL:=COL+1
     UNTIL(TABPOS(COL,TABSTOPS))
    ELSE IF(C=NEWLINE)THEN BEGIN
      PUTC(NEWLINE);
      COL:=1
    END
    ELSE BEGIN
      PUTC(C);
      COL:=COL+1
    END
END;




SHAR_EOF
if test 2054 -ne "`wc -c < 'chapter1.pas'`"
then
	echo shar: error transmitting "'chapter1.pas'" '(should have been 2054 characters)'
fi
fi # end of overwriting check
if test -f 'chapter2.pas'
then
	echo shar: will not over-write existing file "'chapter2.pas'"
else
cat << \SHAR_EOF > 'chapter2.pas'
{chapter2.pas}

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

PROCEDURE TRANSLIT;FORWARD;
PROCEDURE ENTAB;FORWARD;
PROCEDURE EXPAND;FORWARD;
PROCEDURE ECHO;FORWARD;
PROCEDURE COMPRESS;FORWARD;
PROCEDURE OVERSTRIKE;FORWARD;


PROCEDURE OVERSTRIKE;
CONST
  SKIP=BLANK;
  NOSKIP=PLUS;
VAR
  C:CHARACTER;
  COL,NEWCOL,I:INTEGER;
BEGIN
  COL:=1;
  REPEAT
    NEWCOL:=COL;
    WHILE(GETC(C)=BACKSPACE) DO
      NEWCOL:=MAX(NEWCOL-1,1);
    IF (NEWCOL<COL) THEN BEGIN
      PUTC(NEWLINE);
      PUTC(NOSKIP);
      FOR I:=1 TO NEWCOL-1 DO
        PUTC(BLANK);
      COL:=NEWCOL
    END
    ELSE IF (COL=1) AND (C<>ENDFILE) THEN
      PUTC(SKIP);
    IF(C<>ENDFILE)THEN BEGIN
      PUTC(C);
      IF (C=NEWLINE) THEN
        COL:=1
      ELSE
        COL:=COL+1
      END
    UNTIL (C=ENDFILE)
  END;

PROCEDURE COMPRESS;
CONST
  WARNING=CARET;
VAR
  C,LASTC:CHARACTER;
  N:INTEGER;

PROCEDURE PUTREP(N:INTEGER;C:CHARACTER);CONST
  MAXREP=26;
  THRESH=4;
BEGIN
  WHILE(N>=THRESH)OR((C=WARNING)AND(N>0))DO BEGIN
    PUTC(WARNING);
    PUTC(MIN(N,MAXREP)-1+ORD('A'));
    PUTC(C);
    N:=N-MAXREP
  END;
  FOR N:=N DOWNTO 1 DO
    PUTC(C)
  END;

BEGIN(*COMPRESS*)
  N:=1;
  LASTC:=GETC(LASTC);
  WHILE(LASTC<>ENDFILE) DO BEGIN
    IF(GETC(C)=ENDFILE)THEN BEGIN
      IF(N>1) OR(LASTC=WARNING) THEN
        PUTREP(N,LASTC)
      ELSE
        PUTC(LASTC)
      END
      ELSE IF (C=LASTC) THEN
        N:=N+1
      ELSE IF (N>1) OR (LASTC=WARNING) THEN BEGIN
        PUTREP(N,LASTC);
        N:=1
      END
      ELSE
         PUTC(LASTC);
      LASTC:=C
    END
  END;
  
  PROCEDURE EXPAND;
  CONST
    WARNING=CARET;
   VAR
     C:CHARACTER;
     N:INTEGER;
  BEGIN
    WHILE(GETC(C)<>ENDFILE) DO
      IF (C<>WARNING)THEN
        PUTC(C)
      ELSE IF(ISUPPER(GETC(C))) THEN BEGIN
        N:=C-ORD('A')+1;
        IF(GETC(C)<>ENDFILE)THEN
          FOR N:=N DOWNTO 1 DO
            PUTC(C)
          ELSE BEGIN
            PUTC(WARNING);
            PUTC(N-1+ORD('A'))
          END
      END
      ELSE BEGIN
        PUTC(WARNING);
        IF(C<>ENDFILE) THEN
          PUTC(C)
      END
  END;


PROCEDURE ECHO;
VAR
  I,J:INTEGER;
  ARGSTR:XSTRING;
BEGIN
  I:=2;
  WHILE(GETARG(I,ARGSTR,MAXSTR))DO BEGIN
    IF(I>1) THEN PUTC(BLANK);
    FOR J:=1 TO XLENGTH(ARGSTR) DO
      PUTC(ARGSTR[J]);
    I:=I+1
  END;
  IF(I>1)THEN PUTC(NEWLINE)
END;



PROCEDURE ENTAB;
CONST
  MAXLINE=1000;
TYPE
  TABTYPE=ARRAY[1..MAXLINE] OF BOOLEAN;
VAR
  C:CHARACTER;
  COL,NEWCOL:INTEGER;
  TABSTOPS:TABTYPE;

FUNCTION TABPOS(COL:INTEGER;VAR TABSTOPS:TABTYPE):BOOLEAN;
BEGIN
  IF(COL>MAXLINE)THEN
    TABPOS:=TRUE
  ELSE
    TABPOS:=TABSTOPS[COL]
END;

PROCEDURE SETTABS(VAR TABSTOPS:TABTYPE);
CONST
  TABSPACE=4;
VAR
  I:INTEGER;
BEGIN
  FOR I:=1 TO MAXLINE DO
    TABSTOPS[I]:=(I MOD TABSPACE = 1)
END;

    BEGIN
  SETTABS(TABSTOPS);
  COL:=1;
  REPEAT
    NEWCOL:=COL;
    WHILE(GETC(C)=BLANK) DO BEGIN
      NEWCOL:=NEWCOL+1;
      IF(TABPOS(NEWCOL,TABSTOPS))THEN BEGIN
        PUTC(TAB);
        COL:=NEWCOL;
      END
    END;
    WHILE (COL<NEWCOL) DO BEGIN
      PUTC(BLANK);
      COL:=COL+1
    END;
    IF(C<>ENDFILE) THEN BEGIN
      PUTC(C);
      IF(C=NEWLINE) THEN
        COL:=1
      ELSE
        COL:=COL+1
      END
    UNTIL(C=ENDFILE)
  END;



PROCEDURE TRANSLIT;
CONST
  NEGATE=CARET;
VAR
  ARG,FROMSET,TOSET:XSTRING;
  C:CHARACTER;
  I,LASTTO:0..MAXSTR;
  ALLBUT,SQUASH:BOOLEAN;
FUNCTION XINDEX(VAR INSET:XSTRING;C:CHARACTER;
  ALLBUT:BOOLEAN;LASTTO:INTEGER):INTEGER;
BEGIN
  IF(C=ENDFILE)THEN XINDEX:=0
  ELSE IF (NOT ALLBUT) THEN
    XINDEX:=INDEX(INSET,C)
  ELSE IF(INDEX(INSET,C)>0)THEN
    XINDEX:=0
  ELSE
    XINDEX:=LASTTO+1
END;
  
FUNCTION MAKESET(VAR INSET:XSTRING;K:INTEGER;
  VAR OUTSET:XSTRING;MAXSET:INTEGER):BOOLEAN;

VAR J:INTEGER;

PROCEDURE DODASH(DELIM:CHARACTER;VAR SRC:XSTRING;
  VAR I:INTEGER;VAR DEST:XSTRING;
  VAR J:INTEGER;MAXSET:INTEGER);
VAR
  K:INTEGER;
  JUNK:BOOLEAN;
BEGIN
  WHILE (SRC[I]<>DELIM)AND(SRC[I]<>ENDSTR)DO BEGIN
    IF(SRC[I]=ATSIGN)THEN
      JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
    ELSE IF (SRC[I]<>DASH) THEN
      JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
    ELSE IF (J<=1)OR(SRC[I+1]=ENDSTR)THEN
      JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
    ELSE IF (ISALPHANUM(SRC[I-1]))
      AND (ISALPHANUM(SRC[I+1]))
      AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
        FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
          JUNK:=ADDSTR(K,DEST,J,MAXSET);
        I:=I+1
      END
    ELSE
      JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
    I:=I+1
  END
  
END;(*DODASH*)

BEGIN(*MAKESET*)
  J:=1;
  DODASH(ENDSTR,INSET,K,OUTSET,J,MAXSET);
  MAKESET:=ADDSTR(ENDSTR,OUTSET,J,MAXSET)
END;(*MAKESET*)

BEGIN(*TRANSLIT*)
  IF (NOT GETARG(2,ARG,MAXSTR))THEN
    ERROR('USAGE:TRANSLIT FROM TO');
  ALLBUT:=(ARG[1]=NEGATE);
  IF(ALLBUT)THEN
    I:=2
  ELSE
    I:=1;
  IF (NOT MAKESET(ARG,I,FROMSET,MAXSTR)) THEN
    ERROR('TRANSLIT:"FROM"SET TOO LARGE');
  IF(NOT GETARG(3,ARG,MAXSTR))THEN
    TOSET[1]:=ENDSTR
  ELSE IF (NOT MAKESET(ARG,1,TOSET,MAXSTR)) THEN
    ERROR('TRANSLIT:"TO"SET TOO LARGE')
  ELSE IF (XLENGTH(FROMSET)<XLENGTH(TOSET))THEN
    ERROR('TRANSLIT:"FROM"SHORTER THAN "TO');
  
  LASTTO:=XLENGTH(TOSET);
  SQUASH:=(XLENGTH(FROMSET)>LASTTO) OR (ALLBUT);
  REPEAT
    I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO);
    IF (SQUASH) AND(I>=LASTTO) AND (LASTTO>0) THEN BEGIN
      PUTC(TOSET[LASTTO]);
      REPEAT
        I:=XINDEX(FROMSET,GETC(C),ALLBUT,LASTTO)
      UNTIL (I<LASTTO)
    END;
    IF(C<>ENDFILE) THEN BEGIN
      IF(I>0)AND(LASTTO>0) THEN
        PUTC(TOSET[I])
      ELSE IF (I=0)THEN
        PUTC(C)
      (*ELSE DELETE*)
    END
  UNTIL(C=ENDFILE)
END;




SHAR_EOF
if test 6124 -ne "`wc -c < 'chapter2.pas'`"
then
	echo shar: error transmitting "'chapter2.pas'" '(should have been 6124 characters)'
fi
fi # end of overwriting check
if test -f 'chapter3.pas'
then
	echo shar: will not over-write existing file "'chapter3.pas'"
else
cat << \SHAR_EOF > 'chapter3.pas'
{chapter3.pas}

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

PROCEDURE COMPARE;FORWARD;
PROCEDURE INCLUDE;FORWARD;
PROCEDURE CONCAT;FORWARD;

PROCEDURE MAKECOPY;
VAR
  INNAME,OUTNAME:XSTRING;
  FIN,FOUT:FILEDESC;
BEGIN
  IF(NOT GETARG(2,INNAME,MAXSTR))
    OR (NOT GETARG(3,OUTNAME,MAXSTR))THEN
      ERROR('USAGE:MAKECOPY OLD NEW');
  FIN:=MUSTOPEN(INNAME,IOREAD);
  FOUT:=MUSTCREATE(OUTNAME,IOWRITE);
  FCOPY(FIN,FOUT);
  XCLOSE(FIN);
  XCLOSE(FOUT)
END;

PROCEDURE PRINT;
VAR
  NAME:XSTRING;
  NULL:XSTRING;
  I:INTEGER;
  FIN:FILEDESC;
  JUNK:BOOLEAN;

PROCEDURE FPRINT(VAR NAME:XSTRING;FIN:FILEDESC);
CONST
  MARGIN1=2;
  MARGIN2=2;
  BOTTOM=64;
  PAGELEN=66;
VAR
  LINE:XSTRING;
  LINENO,PAGENO:INTEGER;

PROCEDURE SKIP(N:INTEGER);
VAR
  I:INTEGER;
BEGIN
  FOR I:=1 TO N DO
    PUTC(NEWLINE)
END;

PROCEDURE HEAD(VAR NAME:XSTRING;PAGENO:INTEGER);
VAR
  PAGE:XSTRING;
BEGIN
  PAGE[1]:=ORD(' ');
  PAGE[2]:=ORD('P');
  PAGE[3]:=ORD('a');
  PAGE[4]:=ORD('g');
  PAGE[5]:=ORD('e');
  PAGE[6]:=ORD(' ');
  PAGE[7]:=ENDSTR;
  PUTSTR(NAME,STDOUT);
  PUTSTR(PAGE,STDOUT);
  PUTDEC(PAGENO,1);
  PUTC(NEWLINE)
END;

BEGIN(*FPRINT*)
  PAGENO:=1;
  SKIP(MARGIN1);
  HEAD(NAME,PAGENO);
  SKIP(MARGIN2);
  LINENO:=MARGIN1+MARGIN2+1;
  WHILE(GETLINE(LINE,FIN,MAXSTR))DO BEGIN
    IF(LINENO=0)THEN BEGIN
      SKIP(MARGIN1);;
      PAGENO:=PAGENO+1;
      HEAD(NAME,PAGENO);
      SKIP(MARGIN2);
      LINENO:=MARGIN1+MARGIN2+1
    END;
    PUTSTR(LINE,STDOUT);
    LINENO:=LINENO+1;
    IF(LINENO>=BOTTOM)THEN BEGIN
      SKIP(PAGELEN-LINENO);
      LINENO:=0
    END
  END;
  IF(LINENO>0)THEN
    SKIP(PAGELEN-LINENO)
END;
  
BEGIN(*PRINT*)
  NULL[1]:=ENDSTR;
  IF(NARGS=1)THEN
    FPRINT(NULL,STDIN)
  ELSE
    FOR I:=2 TO NARGS DO BEGIN
      JUNK:=GETARG(I,NAME,MAXSTR);
      FIN:=MUSTOPEN(NAME,IOREAD);
      FPRINT(NAME,FIN);
      XCLOSE(FIN)
    END
END;

PROCEDURE COMPARE;
VAR
  LINE1,LINE2:XSTRING;
  ARG1,ARG2:XSTRING;
  LINENO:INTEGER;
  INFILE1,INFILE2:FILEDESC;
  F1,F2:BOOLEAN;
  
PROCEDURE DIFFMSG (N:INTEGER; VAR LINE1,LINE2:XSTRING);
BEGIN
  PUTDEC(N,1);
  PUTC(COLON);
  PUTC(NEWLINE);
  PUTSTR(LINE1,STDOUT);
  PUTSTR(LINE2,STDOUT)
END;

BEGIN(*COMPARE*)
  IF (NOT GETARG(2,ARG1,MAXSTR))
   OR (NOT GETARG(3,ARG2,MAXSTR)) THEN
     ERROR('USAGE:COMPARE FILE1 FILE2');
  INFILE1:=MUSTOPEN(ARG1,IOREAD);
  INFILE2:=MUSTOPEN(ARG2,IOREAD);
  LINENO:=0;
  REPEAT
    LINENO:=LINENO+1;
    F1:=GETLINE(LINE1,INFILE1,MAXSTR);
    F2:=GETLINE(LINE2,INFILE2,MAXSTR);
    IF (F1 AND F2) THEN
      IF (NOT EQUAL(LINE1,LINE2)) THEN
        DIFFMSG(LINENO,LINE1,LINE2)
  UNTIL (F1=FALSE) OR (F2=FALSE);
  IF(F2 AND NOT F1) THEN
  WRITELN('COMPARE:END OF FILE ON FILE 1')
  ELSE IF (F1 AND NOT F2) THEN
    WRITELN('COMPARE:END OF FILE ON FILE2')
END;


PROCEDURE INCLUDE;
VAR
  INCL:XSTRING;

PROCEDURE FINCLUDE(F:FILEDESC);
VAR
  LINE,STR:XSTRING;
  LOC,I:INTEGER;
  F1:FILEDESC;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;
  VAR OUT:XSTRING):INTEGER;

VAR
  J:INTEGER;
BEGIN
  WHILE(S[I] IN [BLANK,TAB,NEWLINE]) DO
    I:=I+1;
  J:=1;
  WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
    OUT[J]:=S[I];
    I:=I+1;
    J:=J+1
  END;
  OUT[J]:=ENDSTR;
  IF(S[I]=ENDSTR) THEN
    GETWORD:=0
  ELSE
    GETWORD:=I
END;

BEGIN
  WHILE (GETLINE(LINE,F,MAXSTR))DO BEGIN
    LOC:=GETWORD(LINE,1,STR);
    IF (NOT EQUAL(STR,INCL)) THEN
      PUTSTR(LINE,STDOUT)
    ELSE BEGIN
      LOC:=GETWORD(LINE,LOC,STR);
      STR[XLENGTH(STR)]:=ENDSTR;
      FOR I:= 1 TO XLENGTH(STR)DO
        STR[I]:=STR[I+1];
      F1:=MUSTOPEN(STR,IOREAD);
      FINCLUDE(F1);
      XCLOSE(F1)
    END
  END
END;

BEGIN
  INCL[1]:=ORD('#');
  INCL[2]:=ORD('i');
  INCL[3]:=ORD('n');
  INCL[4]:=ORD('c');
  INCL[5]:=ORD('l');
  INCL[6]:=ORD('u');
  INCL[7]:=ORD('d');
  INCL[8]:=ORD('e');
  INCL[9]:=ENDSTR;
  FINCLUDE(STDIN)
END;
  
PROCEDURE CONCAT;
VAR
  I:INTEGER;
  JUNK:BOOLEAN;
  FD:FILEDESC;
  S:XSTRING;
BEGIN
  FOR I:=2 TO NARGS DO BEGIN
    JUNK:=GETARG(I,S,MAXSTR);
    FD:=MUSTOPEN(S,IOREAD);
    FCOPY(FD,STDOUT);
    XCLOSE(FD)
  END
END;

PROCEDURE ARCHIVE;
CONST
  MAXFILES=10;
VAR
  ANAME:XSTRING;
  CMD:XSTRING;
  FNAME:ARRAY[1..MAXFILES]OF XSTRING;
  FSTAT:ARRAY[1..MAXFILES] OF BOOLEAN;
  NFILES:INTEGER;
  ERRCOUNT:INTEGER;
  ARCHTEMP:XSTRING;
  ARCHHDR:XSTRING;
FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:XSTRING):INTEGER;
VAR
  J:INTEGER;
BEGIN
  WHILE (S[I] IN [BLANK,TAB,NEWLINE]) DO
    I:=I+1;
  J:=1;
  WHILE(NOT (S[I] IN [ENDSTR,BLANK,TAB,NEWLINE])) DO BEGIN
    OUT[J]:=S[I];
    I:=I+1;
    J:=J+1
  END;
  OUT[J]:=ENDSTR;
  IF(S[I]=ENDSTR) THEN
    GETWORD:=0
  ELSE
    GETWORD:=I
END;


FUNCTION GETHDR(FD:FILEDESC;VAR BUF,NAME:XSTRING;
  VAR SIZE:INTEGER):BOOLEAN;
VAR
  TEMP:XSTRING;
  I:INTEGER;
BEGIN
  IF(GETLINE(BUF,FD,MAXSTR)=FALSE)THEN
    GETHDR:=FALSE
  ELSE BEGIN
    I:=GETWORD(BUF,1,TEMP);
    IF(NOT EQUAL(TEMP,ARCHHDR))THEN
      ERROR('ARCHIVE NOT IN PROPER FORMAT');
    I:=GETWORD(BUF,I,NAME);
    SIZE:=CTOI(BUF,I);
    GETHDR:=TRUE
  END
END;

FUNCTION FILEARG (VAR NAME:XSTRING):BOOLEAN;
VAR
  I:INTEGER;
  FOUND:BOOLEAN;
BEGIN
  IF(NFILES<=0)THEN
    FILEARG:=TRUE
  ELSE BEGIN
    FOUND:=FALSE;
    I:=1;
    WHILE(NOT FOUND) AND (I<=NFILES)DO BEGIN
      IF(EQUAL(NAME,FNAME[I])) THEN BEGIN
        FSTAT[I]:=TRUE;
        FOUND:=TRUE
      END;
      I:=I+1
    END;
    FILEARG:=FOUND
  END
END;

PROCEDURE FSKIP(FD:FILEDESC;N:INTEGER);
VAR
  C:CHARACTER;
  I:INTEGER;
BEGIN
  FOR I:=1 TO N DO
    IF(GETCF(C,FD)=ENDFILE)THEN
      ERROR('ARCHIVE:END OF FILE IN FSKIP')
END;

PROCEDURE FMOVE(VAR NAME1,NAME2:XSTRING);
VAR
  FD1,FD2:FILEDESC;
BEGIN
  FD1:=MUSTOPEN(NAME1,IOREAD);
  FD2:=MUSTCREATE(NAME2,IOWRITE);
  FCOPY(FD1,FD2);
  XCLOSE(FD1);
  XCLOSE(FD2)
END;


PROCEDURE ACOPY(FDI,FDO:FILEDESC;N:INTEGER);
VAR
  C:CHARACTER;
  I:INTEGER;
BEGIN
  FOR I:=1 TO N DO
    IF (GETCF(C,FDI)=ENDFILE)THEN
      ERROR('ARCHIVE: END OF FILE IN ACOPY')
    ELSE
      PUTCF(C,FDO)
END;

PROCEDURE NOTFOUND;
VAR
  I:INTEGER;
BEGIN
  FOR I := 1 TO NFILES DO
    IF(FSTAT[I]=FALSE)THEN BEGIN
      PUTSTR(FNAME[I],STDERR);
      WRITELN(':NOT IN ARCHIVE');
      ERRCOUNT:=ERRCOUNT + 1
    END
END;

PROCEDURE ADDFILE(VAR NAME:XSTRING;FD:FILEDESC);
VAR
  HEAD:XSTRING;
  NFD:FILEDESC;
PROCEDURE MAKEHDR(VAR NAME,HEAD:XSTRING);
VAR
  I:INTEGER;
FUNCTION FSIZE(VAR NAME:XSTRING):INTEGER;
VAR
  C:CHARACTER;
  FD:FILEDESC;
  N:INTEGER;
BEGIN
  N:=0;
  FD:=MUSTOPEN(NAME,IOREAD);
  WHILE(GETCF(C,FD)<>ENDFILE)DO
    N:=N+1;
  XCLOSE(FD);
  FSIZE:=N
END;

BEGIN
  SCOPY(ARCHHDR,1,HEAD,1);
  I:=XLENGTH(HEAD)+1;
  HEAD[I]:=BLANK;
  SCOPY(NAME,1,HEAD,I+1);
  I:=XLENGTH(HEAD)+1;
  HEAD[I]:=BLANK;
  I:=ITOC(FSIZE(NAME),HEAD,I+1);
  HEAD[I]:=NEWLINE;
  HEAD[I+1]:=ENDSTR
END;

BEGIN
  NFD:=OPEN(NAME,IOREAD);
  IF(NFD=IOERROR)THEN BEGIN
    PUTSTR(NAME,STDERR);
    WRITELN(':CAN''T ADD');
    ERRCOUNT:=ERRCOUNT+1
  END;
  IF(ERRCOUNT=0)THEN BEGIN
    MAKEHDR(NAME,HEAD);
    PUTSTR(HEAD,FD);
    FCOPY(NFD,FD);
    XCLOSE(NFD)
  END
END;


PROCEDURE REPLACE(AFD,TFD:FILEDESC;CMD:INTEGER);
VAR
  PINLINE,UNAME:XSTRING;
  SIZE:INTEGER;
BEGIN
  WHILE(GETHDR(AFD,PINLINE,UNAME,SIZE))DO
    IF(FILEARG(UNAME))THEN BEGIN
      IF(CMD=ORD('U'))THEN
        ADDFILE(UNAME,TFD);
      FSKIP(AFD,SIZE)
    END
    ELSE BEGIN
      PUTSTR(PINLINE,TFD);
      ACOPY(AFD,TFD,SIZE)
    END
END;

PROCEDURE HELP;
BEGIN
  ERROR('USAGE:ARCHIVE -[CDPTUX] ARCHNAME [FILES...]')
END;


PROCEDURE GETFNS;
VAR
  I,J:INTEGER;
  JUNK:BOOLEAN;
BEGIN
  ERRCOUNT:=0;
  NFILES:=NARGS-3;
  IF(NFILES>MAXFILES)THEN
    ERROR('ARCHIVE:TO MANY FILE NAMES');
  FOR I:=1 TO NFILES DO
    JUNK:=GETARG(I+3,FNAME[I],MAXSTR);
  FOR I:=1 TO NFILES DO
   FSTAT[I]:=FALSE;
  FOR I:=1 TO NFILES-1 DO
    FOR J:=I+1 TO NFILES DO
      IF(EQUAL(FNAME[I],FNAME[J]))THEN BEGIN
        PUTSTR(FNAME[I],STDERR);
        ERROR(':DUPLICATE FILENAME')
      END
END;


PROCEDURE UPDATE(VAR ANAME:XSTRING;CMD:CHARACTER);
VAR
  I:INTEGER;
  AFD,TFD:FILEDESC;
BEGIN
  TFD:=MUSTCREATE(ARCHTEMP,IOWRITE);
  IF(CMD=ORD('u')) THEN BEGIN
   AFD:=MUSTOPEN(ANAME,IOREAD);
   REPLACE(AFD,TFD,ORD('u'));(*UPDATE EXISTING*)
   XCLOSE(AFD)
 END;
 FOR I:=1 TO NFILES DO
   IF(FSTAT[I]=FALSE)THEN BEGIN
      ADDFILE(FNAME[I],TFD);
      FSTAT[I]:=TRUE
    END;
    XCLOSE(TFD);
    IF(ERRCOUNT=0)THEN
      FMOVE(ARCHTEMP,ANAME)
    ELSE
      WRITELN('FATAL ERRORS - ARCHIVE NOT ALTERED');
    REMOVE (ARCHTEMP)
  END;
PROCEDURE TABLE(VAR ANAME:XSTRING);
VAR
  HEAD,NAME:XSTRING;
  SIZE:INTEGER;
  AFD:FILEDESC;
PROCEDURE TPRINT(VAR BUF:XSTRING);
VAR
  I:INTEGER;
  TEMP:XSTRING;
BEGIN
  I:=GETWORD(BUF,1,TEMP);
  I:=GETWORD(BUF,I,TEMP);
  PUTSTR(TEMP,STDOUT);
  PUTC(BLANK);
  I:=GETWORD(BUF,I,TEMP);(*SIZE*)
  PUTSTR(TEMP,STDOUT);
  PUTC(NEWLINE)
END;

BEGIN
  AFD:=MUSTOPEN(ANAME,IOREAD);
  WHILE(GETHDR(AFD,HEAD,NAME,SIZE))DO BEGIN
    IF(FILEARG(NAME))THEN
      TPRINT(HEAD);
    FSKIP(AFD,SIZE)
  END;
  NOTFOUND
END;

PROCEDURE EXTRACT (VAR ANAME:XSTRING;CMD:CHARACTER);
VAR
  ENAME,PINLINE:XSTRING;
  AFD,EFD:FILEDESC;
  SIZE : INTEGER;
BEGIN
  AFD:=MUSTOPEN(ANAME,IOREAD);
  IF (CMD=ORD('p')) THEN
    EFD:=STDOUT
  ELSE
    EFD:=IOERROR;
  WHILE (GETHDR(AFD,PINLINE,ENAME,SIZE)) DO
    IF (NOT FILEARG(ENAME))THEN
      FSKIP(AFD,SIZE)
    ELSE
      BEGIN
      IF (EFD<> STDOUT) THEN
        EFD:=CREATE(ENAME,IOWRITE);
      IF(EFD=IOERROR) THEN BEGIN
        PUTSTR(ENAME,STDERR);
        WRITELN(': CANT''T CREATE');
        ERRCOUNT:=ERRCOUNT+1;
        FSKIP(AFD,SIZE)
      END
      ELSE BEGIN
        ACOPY(AFD,EFD,SIZE);
        IF(EFD<>STDOUT)THEN
        XCLOSE(EFD)
      END
    END;
    NOTFOUND
  END;

PROCEDURE DELETE(VAR ANAME:XSTRING);
VAR
  AFD,TFD:FILEDESC;
BEGIN
  IF(NFILES<=0)THEN(*PROTECT INNOCENT*)
    ERROR('ARCHIVE:-D REQUIRES EXPLICIT FILE NAMES');
  AFD:=MUSTOPEN(ANAME,IOREAD);
  TFD:=MUSTCREATE(ARCHTEMP,IOWRITE);
  REPLACE(AFD,TFD,ORD('d'));
  NOTFOUND;
  XCLOSE(AFD);
  XCLOSE(TFD);
  IF(ERRCOUNT=0)THEN
    FMOVE(ARCHTEMP,ANAME)
  ELSE
    WRITELN('FATAL ERRORS - ARCHIVE NOT ALTERED');
  REMOVE(ARCHTEMP)
END;


PROCEDURE INITARCH;
BEGIN
  ARCHTEMP[1]:=ORD('A');
  ARCHTEMP[2]:=ORD('R');
  ARCHTEMP[3]:=ORD('T');
  ARCHTEMP[4]:=ORD('E');
  ARCHTEMP[5]:=ORD('M');
  ARCHTEMP[6]:=ORD('P');
  ARCHTEMP[7]:=ENDSTR;
  ARCHHDR[1]:=ORD('-');
  ARCHHDR[2]:=ORD('H');
  ARCHHDR[3]:=ORD('-');
  ARCHHDR[4]:=ENDSTR;
END;


BEGIN
  INITARCH;
  IF (NOT GETARG(2,CMD,MAXSTR))
    OR(NOT GETARG(3,ANAME,MAXSTR)) THEN
      HELP;
  GETFNS;
  IF(XLENGTH(CMD)<>2) OR(CMD[1]<>ORD('-')) THEN
    HELP
  ELSE IF (CMD[2]=ORD('c'))OR(CMD[2]=ORD('u'))THEN
    UPDATE(ANAME,CMD[2])
  ELSE IF (CMD[2]=ORD('t'))THEN
    TABLE(ANAME)
  ELSE IF (CMD[2]=ORD('x'))OR(CMD[2]=ORD('p'))THEN
    EXTRACT(ANAME,CMD[2])
  ELSE IF (CMD[2]=ORD('d'))THEN
    DELETE(ANAME)
  ELSE
    HELP
END;



SHAR_EOF
if test 11306 -ne "`wc -c < 'chapter3.pas'`"
then
	echo shar: error transmitting "'chapter3.pas'" '(should have been 11306 characters)'
fi
fi # end of overwriting check
if test -f 'chapter4.pas'
then
	echo shar: will not over-write existing file "'chapter4.pas'"
else
cat << \SHAR_EOF > 'chapter4.pas'
{chapter4.pas}

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

PROCEDURE SORT;
CONST
  MAXCHARS=10000;
  MAXLINES=300;
  MERGEORDER=5;
TYPE
  CHARPOS=1..MAXCHARS;
  CHARBUF=ARRAY[1..MAXCHARS] OF CHARACTER;
  POSBUF=ARRAY[1..MAXLINES] OF CHARPOS;
  POS=0..MAXLINES;
  FDBUF=ARRAY[1..MERGEORDER]OF FILEDESC;
VAR
  LINEBUF:CHARBUF;
  LINEPOS:POSBUF;
  NLINES:POS;
  INFILE:FDBUF;
  OUTFILE:FILEDESC;
  HIGH,LOW,LIM:INTEGER;
  DONE:BOOLEAN;
  NAME:XSTRING;
FUNCTION GTEXT(VAR LINEPOS:POSBUF;VAR NLINES:POS;
  VAR LINEBUF:CHARBUF;INFILE:FILEDESC):BOOLEAN;
VAR
  I,LEN,NEXTPOS:INTEGER;
  TEMP:XSTRING;
  DONE:BOOLEAN;
BEGIN
  NLINES:=0;
  NEXTPOS:=1;
  REPEAT
    DONE:=(GETLINE(TEMP,INFILE,MAXSTR)=FALSE);
    IF(NOT DONE) THEN BEGIN
      NLINES:=NLINES+1;
      LINEPOS[NLINES]:=NEXTPOS;
      LEN:=XLENGTH(TEMP);
      FOR I:=1 TO LEN DO
        LINEBUF[NEXTPOS+I-1]:=TEMP[I];
      LINEBUF[NEXTPOS+LEN]:=ENDSTR;
      NEXTPOS:=NEXTPOS+LEN+1
    END
  UNTIL (DONE) OR (NEXTPOS>= MAXCHARS-MAXSTR)
    OR (NLINES>=MAXLINES);
  GTEXT:=DONE
END;

PROCEDURE PTEXT(VAR LINEPOS:POSBUF;NLINES:INTEGER;
  VAR LINEBUF:CHARBUF;OUTFILE:FILEDESC);
VAR
  I,J:INTEGER;
BEGIN
  FOR I:=1 TO NLINES DO BEGIN
      J:=LINEPOS[I];
      WHILE (LINEBUF[J]<>ENDSTR)DO BEGIN
        PUTCF(LINEBUF[J],OUTFILE);
        J:=J+1
      END
    END
END;

      

PROCEDURE EXCHANGE(VAR LP1,LP2:CHARPOS);
VAR
  TEMP:CHARPOS;
BEGIN
  TEMP:=LP1;
  LP1:=LP2;
  LP2:=TEMP
END;

FUNCTION CMP (I,J:CHARPOS;VAR LINEBUF:CHARBUF)
   :INTEGER;
BEGIN
  WHILE(LINEBUF[I]=LINEBUF[J])
   AND (LINEBUF[I]<>ENDSTR) DO BEGIN
     I:=I+1;
     J:=J+1
   END;
   IF(LINEBUF[I]=LINEBUF[J]) THEN
     CMP:=0
   ELSE IF (LINEBUF[I]=ENDSTR) THEN
     CMP:=-1
   ELSE IF (LINEBUF[J]=ENDSTR) THEN
     CMP:=+1
   ELSE IF (LINEBUF[I]<LINEBUF[J]) THEN
     CMP:=-1
   ELSE
     CMP:=+1
END;(*CMP*)


PROCEDURE QUICK(VAR LINEPOS:POSBUF; NLINE:POS;
  VAR LINEBUF:CHARBUF);
PROCEDURE RQUICK(LO,HI:INTEGER);
VAR
  I,J:INTEGER;
  PIVLINE:CHARPOS;
BEGIN
  IF (LO<HI) THEN BEGIN
    I:=LO;
    J:=HI;
    PIVLINE:=LINEPOS[J];
    REPEAT
      WHILE (I<J)
        AND (CMP(LINEPOS[I],PIVLINE,LINEBUF)<=0) DO
          I:=I+1;
      WHILE  (J>I)
        AND (CMP(LINEPOS[J],PIVLINE,LINEBUF)>=0) DO
          J:=J-1;
      IF(I<J) THEN
      (*OUT OF ORDER PAIR*)
        EXCHANGE(LINEPOS[I],LINEPOS[J])
    UNTIL (I>=J);
    EXCHANGE(LINEPOS[I],LINEPOS[HI]);
    IF(I-LO<HI-I) THEN BEGIN
      RQUICK(LO,I-1);
      RQUICK(I+1,HI)
    END
    ELSE BEGIN
      RQUICK(I+1,HI);
      RQUICK(LO,I-1)
    END
  END
END;(*RQUICK*)

BEGIN(*QUICK*)
  RQUICK(1,NLINES)
END;


PROCEDURE GNAME(N:INTEGER;VAR NAME:XSTRING);
VAR
  JUNK:INTEGER;
  BEGIN
    NAME[1]:=ORD('S');
    NAME[2]:=ORD('T');
    NAME[3]:=ORD('E');
    NAME[4]:=ORD('M');
    NAME[5]:=ORD('P');
    NAME[6]:=ENDSTR;
  JUNK:=ITOC(N,NAME,XLENGTH(NAME)+1)
END;

PROCEDURE GOPEN(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
  NAME:XSTRING;
  I:1..MERGEORDER;
BEGIN
  FOR I:=1 TO F2-F1+1 DO BEGIN
    GNAME(F1+I-1,NAME);
    INFILE[I]:=MUSTOPEN(NAME,IOREAD)
  END
END;

PROCEDURE GREMOVE(VAR INFILE:FDBUF;F1,F2:INTEGER);
VAR
  NAME:XSTRING;
  I:1..MERGEORDER;
BEGIN
  FOR I:= 1 TO F2-F1+1 DO BEGIN
    XCLOSE(INFILE[I]);
    GNAME(F1+I-1,NAME);
    REMOVE(NAME)
  END
END;


FUNCTION MAKEFILE(N:INTEGER):FILEDESC;
VAR
  NAME:XSTRING;
BEGIN
  GNAME(N,NAME);

  MAKEFILE:=MUSTCREATE(NAME,IOWRITE)
END;

PROCEDURE MERGE(VAR INFILE:FDBUF; NF:INTEGER;
  OUTFILE:FILEDESC);

VAR
  I,J:INTEGER;
  LBP:CHARPOS;
  TEMP:XSTRING;

PROCEDURE REHEAP(VAR LINEPOS:POSBUF;NF:POS;
  VAR LINEBUF:CHARBUF);
VAR
  I,J:INTEGER;
BEGIN
  I:=1;
  J:=2*I;
  WHILE(J<=NF)DO BEGIN
    IF(J<NF) THEN
      IF(CMP(LINEPOS[J],LINEPOS[J+1],LINEBUF)>0)THEN
        J:=J+1;
    IF(CMP(LINEPOS[I],LINEPOS[J],LINEBUF)<=0)THEN
      I:=NF
    ELSE
      EXCHANGE(LINEPOS[I],LINEPOS[J]);(*PERCOLATE*)
    I:=J;
    J:=2*I
  END
END;

PROCEDURE SCCOPY(VAR S:XSTRING; VAR CB:CHARBUF;
  I:CHARPOS);
VAR J:INTEGER;
BEGIN
  J:=1;
  WHILE(S[J]<>ENDSTR)DO BEGIN
    CB[I]:=S[J];
    J:=J+1;
    I:=I+1
  END;
  CB[I]:=ENDSTR
END;

PROCEDURE CSCOPY(VAR CB:CHARBUF;I:CHARPOS;
  VAR S:XSTRING);
VAR J:INTEGER;
BEGIN
  J:=1;
  WHILE(CB[I]<>ENDSTR)DO BEGIN
    S[J]:=CB[I];
    I:=I+1;
    J:=J+1
  END;
  S[J]:=ENDSTR
END;

BEGIN(*MERGE*)
  J:=0;
  FOR I:=1 TO NF DO
    IF(GETLINE(TEMP,INFILE[I],MAXSTR)) THEN BEGIN
      LBP:=(I-1)*MAXSTR+1;
      SCCOPY(TEMP,LINEBUF,LBP);
      LINEPOS[I]:=LBP;
      J:=J+1
    END;
  NF:=J;
  QUICK(LINEPOS,NF,LINEBUF);
  WHILE (NF>0) DO BEGIN
    LBP:=LINEPOS[1];
    CSCOPY(LINEBUF,LBP,TEMP);
    PUTSTR(TEMP,OUTFILE);
    I:=LBP DIV MAXSTR +1;
    IF (GETLINE(TEMP,INFILE[I],MAXSTR))THEN
      SCCOPY(TEMP,LINEBUF,LBP)
    ELSE BEGIN
      LINEPOS[1]:=LINEPOS[NF];
      NF:=NF-1
    END;
    REHEAP(LINEPOS,NF,LINEBUF)
  END
END;


BEGIN
  HIGH:=0;
  REPEAT (*INITIAL FORMTION OF RUNS*)
    DONE:=GTEXT(LINEPOS,NLINES,LINEBUF,STDIN);
    QUICK(LINEPOS,NLINES,LINEBUF);
    HIGH:=HIGH+1;
    OUTFILE:=MAKEFILE(HIGH);
    PTEXT(LINEPOS,NLINES,LINEBUF,OUTFILE);
    XCLOSE(OUTFILE)
  UNTIL (DONE);
  LOW:=1;
  WHILE (LOW<HIGH) DO BEGIN
    LIM:=MIN(LOW+MERGEORDER-1,HIGH);
    GOPEN(INFILE,LOW,LIM);
    HIGH:=HIGH+1;
    OUTFILE:=MAKEFILE(HIGH);
    MERGE(INFILE,LIM-LOW+1,OUTFILE);
    XCLOSE(OUTFILE);
    GREMOVE(INFILE,LOW,LIM);
    LOW:=LOW+MERGEORDER
  END;
  GNAME(HIGH,NAME);
  OUTFILE:=OPEN(NAME,IOREAD);
  FCOPY(OUTFILE,STDOUT);
  XCLOSE(OUTFILE);
  REMOVE(NAME)
END;

PROCEDURE UNIQUE;
VAR
  BUF:ARRAY[0..1] OF XSTRING;
  CUR:0..1;
BEGIN
  CUR:=1;
  BUF[1-CUR][1]:=ENDSTR;
  WHILE (GETLINE(BUF[CUR],STDIN,MAXSTR))DO
    IF (NOT EQUAL (BUF[CUR],BUF[1-CUR])) THEN BEGIN
      PUTSTR(BUF[CUR],STDOUT);
      CUR:=1-CUR
    END
END;

PROCEDURE KWIC;
CONST
  FOLD=DOLLAR;
VAR
  BUF:XSTRING;

PROCEDURE PUTROT(VAR BUF:XSTRING);
VAR I:INTEGER;

PROCEDURE ROTATE(VAR BUF:XSTRING;N:INTEGER);
VAR I:INTEGER;
BEGIN
  I:=N;
  WHILE (BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
    PUTC(BUF[I]);
    I:=I+1
  END;
  PUTC(FOLD);
  FOR I:=1 TO N-1 DO
    PUTC(BUF[I]);
  PUTC(NEWLINE)
END;(*ROTATE*)

BEGIN(*PUTROT*)
  I:=1;
  WHILE(BUF[I]<>NEWLINE) AND (BUF[I]<>ENDSTR) DO BEGIN
    IF (ISALPHANUM(BUF[I])) THEN BEGIN
      ROTATE(BUF,I);(*TOKEN STATRS AT "I"*)
    REPEAT
      I:=I+1
    UNTIL (NOT ISALPHANUM(BUF[I]))
  END;
  I:=I+1
  END
  
END;(*PUTROT*)

BEGIN(*KWIC*)
  WHILE(GETLINE(BUF,STDIN,MAXSTR))DO
    PUTROT(BUF)
END;

PROCEDURE UNROTATE;
CONST
  MAXOUT=80;
  MIDDLE=40;
  FOLD=DOLLAR;
VAR
  INBUF,OUTBUF:XSTRING;
  I,J,F:INTEGER;
BEGIN
  WHILE(GETLINE(INBUF,STDIN,MAXSTR))DO BEGIN
    FOR I:=1 TO MAXOUT-1 DO
      OUTBUF[I]:=BLANK;
    F:=INDEX(INBUF,FOLD);
    J:=MIDDLE-1;
    FOR I:=XLENGTH(INBUF)-1 DOWNTO F+1 DO BEGIN
      OUTBUF[J]:=INBUF[I];
      J:=J-1;
      IF(J<=0)THEN
        J:=MAXOUT-1
    END;
    J:=MIDDLE+1;
    FOR I:=1 TO F-1 DO BEGIN
      OUTBUF[J]:=INBUF[I];
      J:=J MOD (MAXOUT-1) +1
    END;
    FOR J:=1 TO MAXOUT-1 DO
      IF(OUTBUF[J]<>BLANK) THEN
        I:=J;
    OUTBUF[I+1]:=ENDSTR;
    PUTSTR(OUTBUF,STDOUT);
    PUTC(NEWLINE)
  END
END;





SHAR_EOF
if test 7602 -ne "`wc -c < 'chapter4.pas'`"
then
	echo shar: error transmitting "'chapter4.pas'" '(should have been 7602 characters)'
fi
fi # end of overwriting check
if test -f 'chapter5.pas'
then
	echo shar: will not over-write existing file "'chapter5.pas'"
else
cat << \SHAR_EOF > 'chapter5.pas'
{chapter5.pas}

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

CONST
  MAXPAT=MAXSTR;
  CLOSIZE=1;
  CLOSURE=STAR;
  BOL=PERCENT;
  EOL=DOLLAR;
  ANY=QUESTION;
  CCL=LBRACK;
  CCLEND=RBRACK;
  NEGATE=CARET;
  NCCL=EXCLAM;
  LITCHAR=67;

FUNCTION MAKEPAT (VAR ARG:XSTRING; START:INTEGER;
  DELIM:CHARACTER; VAR PAT:XSTRING):INTEGER;FORWARD;
  
FUNCTION AMATCH(VAR LIN:XSTRING;OFFSET:INTEGER;
  VAR PAT:XSTRING; J:INTEGER):INTEGER;FORWARD;
FUNCTION MATCH(VAR LIN,PAT:XSTRING):BOOLEAN;FORWARD;

FUNCTION MAKEPAT;
VAR
  I,J,LASTJ,LJ:INTEGER;
  DONE,JUNK:BOOLEAN;

FUNCTION GETCCL(VAR ARG:XSTRING; VAR I:INTEGER;
  VAR PAT:XSTRING; VAR J:INTEGER):BOOLEAN;
VAR
  JSTART:INTEGER;
  JUNK:BOOLEAN;

PROCEDURE DODASH(DELIM:CHARACTER; VAR SRC:XSTRING;
  VAR I:INTEGER; VAR DEST:XSTRING;
  VAR J:INTEGER; MAXSET:INTEGER);
CONST ESCAPE=ATSIGN;
VAR K:INTEGER;
JUNK:BOOLEAN;

FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
  IF(S[I]<>ESCAPE) THEN
    ESC:=S[I]
  ELSE IF (S[I+1]=ENDSTR) THEN
    ESC:=ESCAPE
  ELSE BEGIN
    I:=I+1;
    IF (S[I]=ORD('N')) THEN
      ESC:=NEWLINE
    ELSE IF (S[I]=ORD('T')) THEN
      ESC:=TAB
    ELSE
      ESC:=S[I]
    END
END;

BEGIN
  WHILE(SRC[I]<>DELIM) AND (SRC[I]<>ENDSTR) DO BEGIN
    IF(SRC[I]=ESCAPE)THEN
      JUNK:=ADDSTR(ESC(SRC,I),DEST,J,MAXSET)
    ELSE IF (SRC[I]<>DASH) THEN
      JUNK:=ADDSTR(SRC[I],DEST,J,MAXSET)
    ELSE IF (J<=1) OR (SRC[I+1]=ENDSTR) THEN
      JUNK:=ADDSTR(DASH,DEST,J,MAXSET)
    ELSE IF (ISALPHANUM(SRC[I-1]))
      AND (ISALPHANUM(SRC[I+1]))
      AND (SRC[I-1]<=SRC[I+1]) THEN BEGIN
        FOR K:=SRC[I-1]+1 TO SRC[I+1] DO
          JUNK:=ADDSTR(K,DEST,J,MAXSET);
            I:=I+1
    END
    ELSE
      JUNK:=ADDSTR(DASH,DEST,J,MAXSET);
    I:=I+1
  END
END;

BEGIN
  I:=I+1;
  IF(ARG[I]=NEGATE) THEN BEGIN
    JUNK:=ADDSTR(NCCL,PAT,J,MAXPAT);
    I:=I+1
  END
  ELSE
    JUNK:=ADDSTR(CCL,PAT,J,MAXPAT);
  JSTART:=J;
  JUNK:=ADDSTR(0,PAT,J,MAXPAT);
  DODASH(CCLEND,ARG,I,PAT,J,MAXPAT);
  PAT[JSTART]:=J-JSTART-1;
  GETCCL:=(ARG[I]=CCLEND)
END;

PROCEDURE STCLOSE(VAR PAT:XSTRING;VAR J:INTEGER;
  LASTJ:INTEGER);
VAR
  JP,JT:INTEGER;
  JUNK:BOOLEAN;
BEGIN
  FOR JP:=J-1 DOWNTO LASTJ DO BEGIN
    JT:=JP+CLOSIZE;
    JUNK:=ADDSTR(PAT[JP],PAT,JT,MAXPAT)
  END;
  J:=J+CLOSIZE;
  PAT[LASTJ]:=CLOSURE
END;
 
BEGIN
  J:=1;
  I:=START;
  LASTJ:=1;
  DONE:=FALSE;
  WHILE(NOT DONE) AND (ARG[I]<>DELIM)
    AND (ARG[I]<>ENDSTR) DO BEGIN
      LJ:=J;
      IF(ARG[I]=ANY) THEN
        JUNK:=ADDSTR(ANY,PAT,J,MAXPAT)
      ELSE IF (ARG[I]=BOL) AND (I=START) THEN
        JUNK:=ADDSTR(BOL,PAT,J,MAXPAT)
      ELSE IF (ARG[I]=EOL) AND (ARG[I+1]=DELIM) THEN
        JUNK:=ADDSTR(EOL,PAT,J,MAXPAT)
      ELSE IF (ARG[I]=CCL) THEN
        DONE:=(GETCCL(ARG,I,PAT,J)=FALSE)
      ELSE IF (ARG[I]=CLOSURE) AND (I>START) THEN BEGIN
        LJ:=LASTJ;
        IF(PAT[LJ] IN [BOL,EOL,CLOSURE]) THEN
          DONE:=TRUE
        ELSE
          STCLOSE(PAT,J,LASTJ)
      END
      ELSE BEGIN
        JUNK:=ADDSTR(LITCHAR,PAT,J,MAXPAT);
        JUNK:=ADDSTR(ESC(ARG,I),PAT,J,MAXPAT)
      END;
      LASTJ:=LJ;
      IF(NOT DONE) THEN
        I:=I+1
    END;
    IF(DONE) OR (ARG[I]<>DELIM) THEN
      MAKEPAT:=0
    ELSE IF (NOT ADDSTR(ENDSTR,PAT,J,MAXPAT)) THEN
      MAKEPAT:=0
    ELSE
      MAKEPAT:=I
  END;
  

FUNCTION AMATCH;


VAR I,K:INTEGER;
   DONE:BOOLEAN;


FUNCTION OMATCH(VAR LIN:XSTRING; VAR I:INTEGER;
  VAR PAT:XSTRING; J:INTEGER):BOOLEAN;
VAR
  ADVANCE:-1..1;


FUNCTION LOCATE (C:CHARACTER; VAR PAT: XSTRING;
  OFFSET:INTEGER):BOOLEAN;
VAR
  I:INTEGER;
BEGIN
  LOCATE:=FALSE;
  I:=OFFSET+PAT[OFFSET];
  WHILE(I>OFFSET) DO
    IF(C=PAT[I]) THEN BEGIN
      LOCATE :=TRUE;
      I:=OFFSET
    END
    ELSE
      I:=I-1
END;BEGIN
  ADVANCE:=-1;
  IF(LIN[I]=ENDSTR) THEN
    OMATCH:=FALSE
  ELSE IF (NOT( PAT[J] IN
   [LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
     ERROR('IN OMATCH:CAN''T HAPPEN')
  ELSE
    CASE PAT[J] OF
    LITCHAR:
      IF (LIN[I]=PAT[J+1]) THEN
        ADVANCE:=1;
    BOL:
      IF (I=1) THEN
        ADVANCE:=0;
    ANY:
      IF (LIN[I]<>NEWLINE) THEN
        ADVANCE:=1;
    EOL:
      IF(LIN[I]=NEWLINE) THEN
        ADVANCE:=0;
    CCL:
      IF(LOCATE(LIN[I],PAT,J+1)) THEN
        ADVANCE:=1;
    NCCL:
      IF(LIN[I]<>NEWLINE)
        AND (NOT LOCATE (LIN[I],PAT,J+1)) THEN
          ADVANCE:=1
        END;
    IF(ADVANCE>=0) THEN BEGIN
      I:=I+ADVANCE;
      OMATCH:=TRUE
    END
    ELSE
      OMATCH:=FALSE
  END;
  
FUNCTION PATSIZE(VAR PAT:XSTRING;N:INTEGER):INTEGER;
BEGIN
  IF(NOT (PAT[N] IN
   [LITCHAR,BOL,EOL,ANY,CCL,NCCL,CLOSURE])) THEN
    ERROR('IN PATSIZE:CAN''T HAPPEN')
  ELSE
    CASE PAT[N] OF
      LITCHAR:PATSIZE:=2;
      BOL,EOL,ANY:PATSIZE:=1;
      CCL,NCCL:PATSIZE:=PAT[N+1]+2;
      CLOSURE:PATSIZE:=CLOSIZE
    END
END;

BEGIN
  DONE:=FALSE;
  WHILE(NOT DONE) AND (PAT[J]<>ENDSTR) DO
    IF(PAT[J]=CLOSURE) THEN BEGIN
      J:=J+PATSIZE(PAT,J);
      I:=OFFSET;
      WHILE(NOT DONE) AND (LIN[I]<>ENDSTR) DO
        IF (NOT OMATCH(LIN,I,PAT,J)) THEN
          DONE:=TRUE;
      DONE:=FALSE;
      WHILE (NOT DONE) AND (I>=OFFSET) DO BEGIN
        K:=AMATCH(LIN,I,PAT,J+PATSIZE(PAT,J));
        IF(K>0) THEN
          DONE:=TRUE
        ELSE
          I:=I-1
      END;
      OFFSET:=K;
      DONE:=TRUE
    END
    ELSE IF (NOT OMATCH(LIN,OFFSET,PAT,J))
      THEN BEGIN
      OFFSET :=0;
      DONE:=TRUE
    END
    ELSE
      J:=J+PATSIZE(PAT,J);
  AMATCH:=OFFSET
END;
FUNCTION MATCH;

VAR
  I,POS:INTEGER;

  
                                                                               
BEGIN
  POS:=0;
  I:=1;
  WHILE(LIN[I]<>ENDSTR) AND (POS=0) DO BEGIN
    POS:=AMATCH(LIN,I,PAT,1);
    I:=I+1
  END;
  MATCH:=(POS>0)
END;




PROCEDURE FIND;
  
VAR
  ARG,LIN,PAT:XSTRING;

FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;

  

BEGIN
  GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;


BEGIN
  IF(NOT GETARG(2,ARG,MAXSTR))THEN
    ERROR('USAGE:FIND PATTERN');
  IF (NOT GETPAT(ARG,PAT)) THEN
    ERROR('FIND:ILLEGAL PATTERN');
  WHILE(GETLINE(LIN,STDIN,MAXSTR))DO
    IF (MATCH(LIN,PAT))THEN
      PUTSTR(LIN,STDOUT)
END;
 
PROCEDURE CHANGE;
CONST
  DITTO=255;
VAR
  LIN,PAT,SUB,ARG:XSTRING;

FUNCTION GETPAT(VAR ARG,PAT:XSTRING):BOOLEAN;

  

BEGIN
  GETPAT:=(MAKEPAT(ARG,1,ENDSTR,PAT)>0)
END;
FUNCTION GETSUB(VAR ARG,SUB:XSTRING):BOOLEAN;

FUNCTION MAKESUB(VAR ARG:XSTRING; FROM:INTEGER;
  DELIM:CHARACTER; VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
   JUNK:BOOLEAN;
BEGIN
  J:=1;
  I:=FROM;
  WHILE (ARG[I]<>DELIM) AND (ARG[I]<>ENDSTR) DO BEGIN
    IF(ARG[I]=ORD('&')) THEN
      JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
    ELSE
      JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
    I:=I+1
  END;
  IF (ARG[I]<>DELIM) THEN
    MAKESUB:=0
  ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT)) THEN
    MAKESUB:=0
  ELSE
    MAKESUB:=I
END;

BEGIN
  GETSUB:=(MAKESUB(ARG,1,ENDSTR,SUB)>0)
END;

PROCEDURE SUBLINE(VAR LIN,PAT,SUB:XSTRING);
VAR
  I, LASTM, M:INTEGER;
  JUNK:BOOLEAN;


PROCEDURE PUTSUB(VAR LIN:XSTRING; S1,S2:INTEGER;
  VAR SUB:XSTRING);
VAR
  I,J:INTEGER;
  JUNK:BOOLEAN;
BEGIN
  I:=1;
  WHILE (SUB[I]<>ENDSTR) DO BEGIN
    IF(SUB[I]=DITTO) THEN
      FOR J:=S1 TO S2-1 DO
        PUTC(LIN[J])
      ELSE
        PUTC(SUB[I]);
      I:=I+1
  END
END;

BEGIN
  LASTM:=0;
  I:=1;
  WHILE(LIN[I]<>ENDSTR) DO BEGIN
    M:=AMATCH(LIN,I,PAT,1);
    IF (M>0) AND (LASTM<>M) THEN BEGIN
      PUTSUB(LIN,I,M,SUB);
      LASTM:=M
    END;
    IF (M=0) OR (M=I) THEN BEGIN
      PUTC(LIN[I]);
      I:=I+1
    END
    ELSE
      I:=M
    END
END;

BEGIN
  IF(NOT GETARG(2,ARG,MAXSTR)) THEN
    ERROR('USAGE:CHANGE FROM [TO]');
  IF (NOT GETPAT(ARG,PAT)) THEN
    ERROR('CHANGE:ILLEGAL "FROM" PATTERN');
  IF (NOT GETARG(3,ARG,MAXSTR)) THEN
    ARG[1]:=ENDSTR;
  IF(NOT GETSUB(ARG,SUB)) THEN
    ERROR('CHANGE:ILLEGAL "TO" STRING');
  WHILE (GETLINE(LIN,STDIN,MAXSTR)) DO
    SUBLINE(LIN,PAT,SUB)
END;



SHAR_EOF
if test 8365 -ne "`wc -c < 'chapter5.pas'`"
then
	echo shar: error transmitting "'chapter5.pas'" '(should have been 8365 characters)'
fi
fi # end of overwriting check
if test -f 'chapter6.pas'
then
	echo shar: will not over-write existing file "'chapter6.pas'"
else
cat << \SHAR_EOF > 'chapter6.pas'
{chapter6.pas}

{
        Copyright (c) 1981
        By:     Bell Telephone Laboratories, Inc. and
                Whitesmith's Ltd.,

        This software is derived from the book
                "Software Tools in Pascal", by
                Brian W. Kernighan and P. J. Plauger
                Addison-Wesley, 1981
                ISBN 0-201-10342-7

        Right is hereby granted to freely distribute or duplicate this
        software, providing distribution or duplication is not for profit
        or other commercial gain and that this copyright notice remains
        intact.
}

PROCEDURE EDIT;
CONST
  MAXLINES=1000;
  DITTO=255;
  CURLINE=PERIOD;
  LASTLINE=DOLLAR;
  SCAN=47;
  BACKSCAN=92;
  ACMD=97;
  CCMD=99;
  DCMD=100;
  ECMD=101;
  EQCMD=EQUALS;
  FCMD=102;
  GCMD=103;
  ICMD=105;
  MCMD=109;
  PCMD=112;
  QCMD=113;
  RCMD=114;
  SCMD=115;
  WCMD=119;
  XCMD=120;

TYPE
  STCODE=(ENDDATA,ERR,OK);
  BUFTYPE=RECORD
    TXT:INTEGER;
    MARK:BOOLEAN;
  END;

VAR
  EDITFID:FILE OF CHARACTER;
  BUF:ARRAY[0..MAXLINES]OF BUFTYPE;
  RECIN:INTEGER;
  RECOUT:INTEGER;
  LINE1,LINE2,NLINES,CURLN,LASTLN:INTEGER;
  PAT,LIN,SAVEFILE:XSTRING;
  CURSAVE,I:INTEGER;
  STATUS:STCODE;
  MORE:BOOLEAN;







PROCEDURE GETTXT(N:INTEGER;VAR S:XSTRING);
VAR
  ch:char;JUNK:BOOLEAN;I:INTEGER;
BEGIN
  IF(N=0) THEN
    S[1]:=ENDSTR
  ELSE BEGIN
    i:=0;
    SEEK(EDITFID,BUF[N].TXT);
    repeat
      i:=succ(i);
      READ(EDITFID,s[i]);
      RECIN:=RECIN+1;
    until S[I]=ENDSTR;
  END
END;


FUNCTION GETMARK(N:INTEGER):BOOLEAN;
BEGIN
  GETMARK:=BUF[N].MARK
END;

PROCEDURE PUTMARK(N:INTEGER;M:BOOLEAN);
BEGIN
  BUF[N].MARK:=M
END;

FUNCTION DOPRINT(N1,N2:INTEGER):STCODE;
VAR
  I:INTEGER;
  LINE:XSTRING;
BEGIN
  IF(N1<=0)THEN
    DOPRINT:=ERR
  ELSE BEGIN
    FOR I:=N1 TO N2 DO BEGIN
      GETTXT(I,LINE);
      PUTSTR(LINE,STDOUT)
    END;
    CURLN:=N2;
    DOPRINT:=OK
  END
END;

FUNCTION DEFAULT(DEF1,DEF2:INTEGER;
  VAR STATUS:STCODE):STCODE;
BEGIN
  IF(NLINES=0)THEN BEGIN
    LINE1:=DEF1;
    LINE2:=DEF2
  END;
  IF(LINE1 > LINE2)OR(LINE1 <=0)THEN
    STATUS:=ERR
  ELSE
    STATUS:=OK;
  DEFAULT:=STATUS
END;

FUNCTION PREVLN(N:INTEGER):INTEGER;
BEGIN
  IF(N<=0)THEN
    PREVLN:=LASTLN
  ELSE
    PREVLN:=N-1
END;

FUNCTION NEXTLN(N:INTEGER):INTEGER;
BEGIN
  IF(N>=LASTLN)THEN
    NEXTLN:=0
  ELSE
    NEXTLN:=N+1
END;

FUNCTION PATSCAN(WAY:CHARACTER;VAR N:INTEGER):STCODE;
VAR
  DONE:BOOLEAN;
  LINE:XSTRING;
BEGIN
  N:=CURLN;
  PATSCAN:=ERR;
  DONE:=FALSE;
  REPEAT
    IF(WAY=SCAN)THEN
      N:=NEXTLN(N)
    ELSE
      N:=PREVLN(N);
    GETTXT(N,LINE);
    IF(MATCH(LINE,PAT))THEN BEGIN
      PATSCAN:=OK;
      DONE:=TRUE
    END
  UNTIL(N=CURLN)OR(DONE)
END;

FUNCTION ESC(VAR S:XSTRING; VAR I:INTEGER):CHARACTER;
BEGIN
  IF(S[I]<>ESCAPE) THEN
    ESC:=S[I]
  ELSE IF (S[I+1]=ENDSTR) THEN
    ESC:=ESCAPE
  ELSE BEGIN
    I:=I+1;
    IF (S[I]=ORD('N')) THEN
      ESC:=NEWLINE
    ELSE IF (S[I]=ORD('T')) THEN
      ESC:=TAB
    ELSE
      ESC:=S[I]
    END
END;
FUNCTION OPTPAT(VAR LIN:XSTRING;VAR I:INTEGER):STCODE;
BEGIN
  IF(LIN[I]=ENDSTR)THEN
    I:=0
  ELSE IF(LIN[I+1]=ENDSTR)THEN
    I:=0
  ELSE IF(LIN[I+1]=LIN[I])THEN
    I:=I+1
  ELSE
    I:=MAKEPAT(LIN,I+1,LIN[I],PAT);
  IF(PAT[1]=ENDSTR)THEN
    I:=0;
  IF(I=0)THEN BEGIN
    PAT[1]:=ENDSTR;
    OPTPAT:=ERR
  END
  ELSE
    OPTPAT:=OK
END;

PROCEDURE SKIPBL(VAR S:XSTRING;VAR I:INTEGER);
BEGIN
  WHILE(S[I]=BLANK)OR(S[I]=TAB)DO
    I:=I+1
END;

FUNCTION GETNUM(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
  VAR STATUS:STCODE):STCODE;
BEGIN
  STATUS:=OK;
  SKIPBL(LIN,I);
  IF(ISDIGIT(LIN[I]))THEN BEGIN
    NUM:=CTOI(LIN,I);
      I:=I-1
  END
  ELSE IF(LIN[I]=CURLINE)THEN
    NUM:=CURLN
  ELSE IF(LIN[I]=LASTLINE)THEN
    NUM:=LASTLN
  ELSE IF(LIN[I]=SCAN)OR(LIN[I]=BACKSCAN)THEN BEGIN
    IF(OPTPAT(LIN,I)=ERR)THEN
      STATUS:=ERR
    ELSE
      STATUS:=PATSCAN(LIN[I],NUM)
  END
  ELSE
    STATUS:=ENDDATA;
  IF(STATUS=OK)THEN
    I:=I+1;
  GETNUM:=STATUS
END;

FUNCTION GETONE(VAR LIN:XSTRING;VAR I,NUM:INTEGER;
  VAR STATUS:STCODE):STCODE;
  VAR
    ISTART,MUL,PNUM:INTEGER;
  BEGIN
    ISTART:=I;
    NUM:=0;
    IF(GETNUM(LIN,I,NUM,STATUS)=OK)THEN
      REPEAT
        SKIPBL(LIN,I);
        IF(LIN[I]<>PLUS)AND(LIN[I]<>MINUS)THEN
          STATUS:=ENDDATA
        ELSE BEGIN
          IF(LIN[I]=PLUS)THEN
            MUL:=+1
          ELSE
            MUL:=-1;
          I:=I+1;
          IF(GETNUM(LIN,I,PNUM,STATUS)=OK)THEN
            NUM:=NUM+MUL*PNUM;
          IF(STATUS=ENDDATA)THEN
            STATUS:=ERR
        END
      UNTIL(STATUS<>OK);
    IF(NUM<0)OR(NUM > LASTLN)THEN
      STATUS:=ERR;
    IF(STATUS<>ERR)THEN BEGIN
      IF(I<=ISTART)THEN
        STATUS:=ENDDATA
      ELSE
        STATUS:=OK
    END;
    GETONE:=STATUS
  END;
  
        
FUNCTION GETLIST(VAR LIN:XSTRING;VAR I:INTEGER;
  VAR STATUS:STCODE):STCODE;
VAR
  NUM:INTEGER;
  DONE:BOOLEAN;
BEGIN
  LINE2:=0;
  NLINES:=0;
  DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK);
  WHILE(NOT DONE)DO BEGIN
    LINE1:=LINE2;
    LINE2:=NUM;
    NLINES:=NLINES+1;
    IF(LIN[I]=SEMICOL)THEN
      CURLN:=NUM;
    IF(LIN[I]=COMMA)OR(LIN[I]=SEMICOL)THEN BEGIN
      I:=I+1;
      DONE:=(GETONE(LIN,I,NUM,STATUS)<>OK)
    END
    ELSE
      DONE:=TRUE
  END;
  NLINES:=MIN(NLINES,2);
  IF(NLINES=0)THEN
    LINE2:=CURLN;
  IF(NLINES<=1)THEN
    LINE1:=LINE2;
  IF(STATUS<>ERR)THEN
    STATUS:=OK;
  GETLIST:=STATUS
END;

PROCEDURE REVERSE(N1,N2:INTEGER);
VAR
  TEMP:BUFTYPE;
BEGIN
  WHILE(N1<N2)DO BEGIN
    TEMP:=BUF[N1];
    BUF[N1]:=BUF[N2];
    BUF[N2]:=TEMP;
    N1:=N1+1;
    N2:=N2-1
  END
END;
PROCEDURE BLKMOVE(N1,N2,N3:INTEGER);
BEGIN
  IF(N3<N1-1)THEN BEGIN
    REVERSE(N3+1,N1-1);
    REVERSE(N1,N2);
    REVERSE(N3+1,N2)
  END
  ELSE IF(N3>N2)THEN BEGIN
    REVERSE(N1,N2);
    REVERSE(N2+1,N3);
    REVERSE(N1,N3)
  END
END;

FUNCTION MOVE(LINE3:INTEGER):STCODE;
BEGIN
  IF(LINE1<=0)OR((LINE3>=LINE1)AND(LINE3<LINE2))THEN
    MOVE:=ERR
  ELSE BEGIN
    BLKMOVE(LINE1,LINE2,LINE3);
    IF(LINE3>LINE1)THEN
      CURLN:=LINE3
    ELSE
       CURLN:=LINE3+(LINE2-LINE1+1);
     MOVE:=OK
   END
 END;
 
FUNCTION LNDELETE(N1,N2:INTEGER;VAR STATUS:STCODE):
STCODE;
BEGIN
  IF(N1<=0)THEN
    STATUS:=ERR
  ELSE BEGIN
    BLKMOVE(N1,N2,LASTLN);
    LASTLN:=LASTLN-(N2-N1+1);
    CURLN:=PREVLN(N1);
    STATUS:=OK
  END;
  LNDELETE:=STATUS
END;

FUNCTION CKP(VAR LIN:XSTRING;I:INTEGER;
  VAR PFLAG:BOOLEAN;VAR STATUS:STCODE):STCODE;
BEGIN
  SKIPBL(LIN,I);
  IF(LIN[I]=PCMD)THEN BEGIN
    I:=I+1;
    PFLAG:=TRUE
  END
  ELSE
    PFLAG:=FALSE;
  IF(LIN[I]=NEWLINE)THEN
    STATUS:=OK
  ELSE
    STATUS:=ERR;
  CKP:=STATUS
END;

FUNCTION PUTTXT(VAR LIN:XSTRING):STCODE;
VAR I:INTEGER;
BEGIN
  PUTTXT:=ERR;
  IF(LASTLN<MAXLINES) THEN BEGIN
    i:=0;
    seek(editfid,recout);
    lastln:=lastln+1;
    buf[lastln].txt:=recout;
    repeat
      i:=succ(i);
      WRITE(EDITFID,lin[i]);
      recout:=recout+1
    until lin[i]=ENDSTR;
    write(editfid,lin[i]);
    PUTMARK(LASTLN,FALSE);
    BLKMOVE(LASTLN,LASTLN,CURLN);
    CURLN:=CURLN+1;
    PUTTXT:=OK
  END
END;

PROCEDURE SETBUF;
BEGIN
(*$I-*)
  ASSIGN(EDITFID,'EDTEMP');
  RESET(EDITFID);
  IF (IORESULT<>0) THEN REWRITE(EDITFID);
(*$I+*)

  RECOUT:=0;
  RECIN:=0;
  CURLN:=0;
  LASTLN:=0
END;


PROCEDURE CLRBUF;
BEGIN
  CLOSE(EDITFID);ERASE(EDITFID)
END;

FUNCTION APPEND(LINE:INTEGER;GLOB:BOOLEAN):STCODE;
VAR
  EINLINE:XSTRING;
  STAT:STCODE;
  DONE:BOOLEAN;
BEGIN
  IF(GLOB)THEN
    STAT:=ERR
  ELSE BEGIN
    CURLN:=LINE;
    STAT:=OK;
    DONE:=FALSE;
    WHILE(NOT DONE)AND(STAT=OK)DO
      IF(NOT GETLINE(EINLINE,STDIN,MAXSTR))THEN
        STAT:=ENDDATA
      ELSE IF(EINLINE[1]=PERIOD)
        AND(EINLINE[2]=NEWLINE)THEN
          DONE:=TRUE
      ELSE IF(PUTTXT(EINLINE)=ERR)THEN
        STAT:=ERR
  END;
  APPEND:=STAT
END;

FUNCTION DOWRITE(N1,N2:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
  I:INTEGER;
  FD: FILEDESC;
  LINE: XSTRING;
BEGIN
  FD:=CREATE(FIL,IOWRITE);
  IF(FD=IOERROR)THEN
    DOWRITE:=ERR
  ELSE BEGIN
    FOR I:=N1 TO N2 DO BEGIN
      GETTXT(I,LINE);
      PUTSTR(LINE,FD)
    END;
    XCLOSE(FD);
    PUTDEC(N2-N1+1,1);
    PUTC(NEWLINE);
    DOWRITE:=OK
  END
END;

FUNCTION DOREAD(N:INTEGER;VAR FIL:XSTRING):STCODE;
VAR
  COUNT:INTEGER;
  T:BOOLEAN;
  STAT:STCODE;
  FD:FILEDESC;
  EINLINE:XSTRING;
BEGIN
  FD:=OPEN(FIL,IOREAD);
  IF(FD=IOERROR)THEN
    STAT:=ERR
  ELSE BEGIN
    CURLN:=N;
    STAT:=OK;
    COUNT:=0;
    REPEAT
      T:=GETLINE(EINLINE,FD,MAXSTR);
      IF(T)THEN BEGIN
        STAT:=PUTTXT(EINLINE);
        IF(STAT<>ERR)THEN
          COUNT:=COUNT+1
      END
    UNTIL(STAT<>OK)OR(T=FALSE);
    XCLOSE(FD);
    PUTDEC(COUNT,1);
    PUTC(NEWLINE)
  END;
  DOREAD:=STAT
END;

FUNCTION GETFN(VAR LIN:XSTRING;VAR I:INTEGER;
  VAR FIL:XSTRING):STCODE;
VAR
  K:INTEGER;
  STAT:STCODE;

FUNCTION GETWORD(VAR S:XSTRING;I:INTEGER;VAR OUT:
  XSTRING):INTEGER;
VAR
  J:INTEGER;
BEGIN
  WHILE(S[I]IN [BLANK,TAB,NEWLINE])DO
    I:=I+1;
  J:=1;
  WHILE(NOT(S[I]IN [ENDSTR,BLANK,TAB,
    NEWLINE]))DO BEGIN
    OUT[J]:=S[I];
    I:=I+1;
    J:=J+1
  END;
  OUT[J]:=ENDSTR;
  IF(S[I]=ENDSTR)THEN
    GETWORD:=0
  ELSE
    GETWORD:=I
END;

BEGIN(*GETFN*)
  STAT:=ERR;
  IF(LIN[I+1]=BLANK)THEN BEGIN
    K:=GETWORD(LIN,I+2,FIL);
    IF(K>0)THEN
      IF(LIN[K]=NEWLINE)THEN
        STAT:=OK
  END
  ELSE IF(LIN[I+1]=NEWLINE)
    AND(SAVEFILE[1]<>ENDSTR)THEN BEGIN
      SCOPY(SAVEFILE,1,FIL,1);
      STAT:=OK;
  END;
  IF(STAT=OK)AND(SAVEFILE[1]=ENDSTR)THEN
    SCOPY(FIL,1,SAVEFILE,1);
  GETFN:=STAT
END;

PROCEDURE CATSUB(VAR LIN:XSTRING;S1,S2: INTEGER;
  VAR SUB: XSTRING;VAR NEW:XSTRING;
  VAR K:INTEGER;MAXNEW:INTEGER);
VAR
  I,J:INTEGER;
  JUNK:BOOLEAN;
BEGIN
  I:=1;
  WHILE(SUB[I]<>ENDSTR)DO BEGIN
    IF(SUB[I]=DITTO)THEN
      FOR J:=S1 TO S2-1 DO
        JUNK:=ADDSTR(LIN[J],NEW,K,MAXNEW)
      ELSE
        JUNK:=ADDSTR(SUB[I],NEW,K,MAXNEW);
      I:=I+1
  END
END;

FUNCTION SUBST( VAR SUB:XSTRING;GFLAG,GLOB:BOOLEAN):STCODE;
VAR
  NEW,OLD:XSTRING;
  J,K,LASTM,LINE,M:INTEGER;
  STAT:STCODE;
  DONE,SUBBED,JUNK:BOOLEAN;
BEGIN
  IF(GLOB)THEN
    STAT:=OK
  ELSE
    STAT:=ERR;
    DONE:=(LINE1<=0);
    LINE:=LINE1;
    WHILE(NOT DONE)AND(LINE<=LINE2)DO BEGIN
      J:=1;
      SUBBED:=FALSE;
      GETTXT(LINE,OLD);
      LASTM:=0;
      K:=1;
      WHILE(OLD[K]<>ENDSTR)DO BEGIN
        IF(GFLAG)OR(NOT SUBBED)THEN
          M:=AMATCH(OLD,K,PAT,1)
        ELSE
          M:=0;
        IF(M>0)AND(LASTM<>M)THEN BEGIN
          SUBBED:=TRUE;
          CATSUB(OLD,K,M,SUB,NEW,J,MAXSTR);
          LASTM:=M
        END;
        IF(M=0)OR(M=K)THEN BEGIN
          JUNK:=ADDSTR(OLD[K],NEW,J,MAXSTR);
          K:=K+1
        END
        ELSE
          K:=M
      END;
      IF(SUBBED)THEN BEGIN
        IF(NOT ADDSTR(ENDSTR,NEW,J,MAXSTR))THEN BEGIN
          STAT:=ERR;
          DONE:=TRUE
        END
        ELSE BEGIN
          STAT:=LNDELETE(LINE,LINE,STATUS);
          STAT:=PUTTXT(NEW);
          LINE2:=LINE2+CURLN-LINE;
          LINE:=CURLN;
          IF(STAT=ERR)THEN
            DONE:=TRUE
          ELSE
            STAT:=OK
          END
        END;
        LINE:=LINE+1
      END;
      SUBST:=STAT
    END;
FUNCTION MAKESUB(VAR ARG:XSTRING;FROM:INTEGER;
  DELIM:CHARACTER;VAR SUB:XSTRING):INTEGER;
VAR I,J:INTEGER;
   JUNK:BOOLEAN;
BEGIN
  J:=1;
  I:=FROM;
  WHILE(ARG[I]<>DELIM)AND(ARG[I]<>ENDSTR)DO BEGIN
    IF(ARG[I]=ORD('&'))THEN
      JUNK:=ADDSTR(DITTO,SUB,J,MAXPAT)
    ELSE
      JUNK:=ADDSTR(ESC(ARG,I),SUB,J,MAXPAT);
    I:=I+1
  END;
  IF(ARG[I]<>DELIM) THEN
    MAKESUB:=0
  ELSE IF (NOT ADDSTR(ENDSTR,SUB,J,MAXPAT))THEN
    MAKESUB:=0
  ELSE
    MAKESUB:=I
END;
FUNCTION GETRHS(VAR LIN:XSTRING;VAR I:INTEGER;
  VAR SUB:XSTRING;VAR GFLAG:BOOLEAN):STCODE;
BEGIN
  GETRHS:=OK;
  IF(LIN[I]=ENDSTR)THEN
    GETRHS:=ERR
  ELSE IF(LIN[I+1]=ENDSTR)THEN
    GETRHS:=ERR
  ELSE BEGIN
    I:=MAKESUB(LIN,I+1,LIN[I],SUB);
    IF(I=0)THEN
      GETRHS:=ERR
    ELSE IF(LIN[I+1]=ORD('G'))THEN BEGIN
      I:=I+1;
      GFLAG:=TRUE
    END
    ELSE
      GFLAG:=FALSE
  END
END;

FUNCTION DOCMD(VAR LIN:XSTRING;VAR I:INTEGER;
  GLOB:BOOLEAN;VAR STATUS:STCODE):STCODE;
VAR
  FIL,SUB:XSTRING;
  LINE3:INTEGER;
  GFLAG,PFLAG:BOOLEAN;
BEGIN
  PFLAG:=FALSE;
  STATUS:=ERR;
  IF(LIN[I]=PCMD)THEN BEGIN
    IF(LIN[I+1]=NEWLINE)THEN 
      IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
        STATUS:=DOPRINT(LINE1,LINE2)
  END
  ELSE IF(LIN[I]=NEWLINE)THEN BEGIN
    IF(NLINES=0)THEN
      LINE2:=NEXTLN(CURLN);
    STATUS:=DOPRINT(LINE2,LINE2)
  END
  ELSE IF(LIN[I]=QCMD)THEN BEGIN
    IF( LIN[I+1]=NEWLINE)AND(NLINES=0)AND(NOT GLOB)THEN
  STATUS:=ENDDATA
  END
  ELSE IF(LIN[I]=ACMD)THEN BEGIN
    IF(LIN[I+1]=NEWLINE)THEN
      STATUS:=APPEND(LINE2,GLOB)
  END
  ELSE IF(LIN[I]=CCMD)THEN BEGIN
    IF(LIN[I+1]=NEWLINE)THEN
      IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
      IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
        STATUS:=APPEND(PREVLN(LINE1),GLOB)
  END
  ELSE IF(LIN[I]=DCMD)THEN BEGIN
    IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
     IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
     IF(LNDELETE(LINE1,LINE2,STATUS)=OK)THEN
     IF(NEXTLN(CURLN)<>0)THEN
       CURLN:=NEXTLN(CURLN)
  END
  ELSE IF(LIN[I]=ICMD)THEN BEGIN
    IF(LIN[I+1]=NEWLINE)THEN BEGIN
      IF(LINE2=0)THEN
        STATUS:=APPEND(0,GLOB)
      ELSE
        STATUS:=APPEND(PREVLN(LINE2),GLOB)
    END
  END
  ELSE IF(LIN[I]=EQCMD)THEN BEGIN
    IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN BEGIN
      PUTDEC(LINE2,1);
      PUTC(NEWLINE)
    END
  END
  ELSE IF(LIN[I]=MCMD)THEN BEGIN
    I:=I+1;
    IF(GETONE(LIN,I,LINE3,STATUS)=ENDDATA)THEN
      STATUS:=ERR;
    IF(STATUS =OK)THEN
      IF(CKP(LIN,I,PFLAG,STATUS)=OK)THEN
      IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
        STATUS:=MOVE(LINE3)
  END
  ELSE IF(LIN[I]=SCMD)THEN BEGIN
    I:=I+1;
    IF(OPTPAT(LIN,I)=OK)THEN 
    IF(GETRHS(LIN,I,SUB,GFLAG)=OK)THEN
    IF(CKP(LIN,I+1,PFLAG,STATUS)=OK)THEN
    IF(DEFAULT(CURLN,CURLN,STATUS)=OK)THEN
      STATUS:=SUBST(SUB,GFLAG,GLOB)
  END
  ELSE IF(LIN[I]=ECMD)THEN BEGIN
    IF(NLINES =0)THEN
      IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
        SCOPY(FIL,1,SAVEFILE,1);
        CLRBUF;
        SETBUF;
        STATUS:=DOREAD(0,FIL)
      END
  END
  ELSE IF(LIN[I]=FCMD)THEN BEGIN
    IF(NLINES =0)THEN
      IF(GETFN(LIN,I,FIL)=OK)THEN BEGIN
        SCOPY(FIL,1,SAVEFILE,1);
        PUTSTR(SAVEFILE,STDOUT);
        PUTC(NEWLINE);
        STATUS:=OK
    END
  END
  ELSE IF(LIN[I]=RCMD)THEN BEGIN
    IF(GETFN(LIN,I,FIL)=OK)THEN
      STATUS:=DOREAD(LINE2,FIL)
  END
  ELSE IF(LIN[I]=WCMD)THEN BEGIN
    IF(GETFN(LIN,I,FIL)=OK)THEN
      IF(DEFAULT(1,LASTLN,STATUS)=OK)THEN
        STATUS:=DOWRITE(LINE1,LINE2,FIL)
  END;
  IF(STATUS =OK)AND(PFLAG)THEN
    STATUS:=DOPRINT(CURLN,CURLN);
  DOCMD:=STATUS
END;(*DOCMD*)

FUNCTION CKGLOB(VAR LIN: XSTRING;VAR I:INTEGER;
  VAR STATUS:STCODE): STCODE;
VAR
  N:INTEGER;
  GFLAG:BOOLEAN;
  TEMP: XSTRING;
BEGIN
  IF(LIN[I]<>GCMD)AND(LIN[I]<>XCMD)THEN
    STATUS:=ENDDATA
  ELSE BEGIN
    GFLAG:=(LIN[I]=GCMD);
    I:=I+1;
    IF(OPTPAT(LIN,I)=ERR)THEN
      STATUS:=ERR
    ELSE IF( DEFAULT(1,LASTLN,STATUS)<>ERR)THEN BEGIN
      I:=I+1;
      FOR N:=LINE1 TO LINE2 DO BEGIN
        GETTXT(N,TEMP);
        PUTMARK(N,(MATCH(TEMP,PAT)=GFLAG))
      END;

      FOR N:=1 TO LINE1-1 DO
        PUTMARK(N,FALSE);
      FOR N:=LINE2+1 TO LASTLN DO
        PUTMARK(N,FALSE);
      STATUS:=OK
    END
  END;
  CKGLOB:=STATUS
END;

FUNCTION DOGLOB(VAR LIN:XSTRING;VAR I,CURSAVE:INTEGER;
  VAR STATUS: STCODE):STCODE;
VAR
  COUNT,ISTART,N: INTEGER;
BEGIN
  STATUS:=OK;
  COUNT:=0;
  N:=LINE1;
  ISTART:=I;
  REPEAT
    IF(GETMARK(N))THEN BEGIN
      PUTMARK(N,FALSE);
      CURLN:=N;
      CURSAVE:=CURLN;
      I:=ISTART;
      IF(DOCMD(LIN,I,TRUE,STATUS)=OK)THEN
        COUNT:=0
    END
    ELSE BEGIN
      N:=NEXTLN(N);
      COUNT:=COUNT + 1
    END
  UNTIL(COUNT > LASTLN)OR(STATUS <> OK);
  DOGLOB:=STATUS
END;

BEGIN
  SETBUF;
  PAT[1]:=ENDSTR;
  SAVEFILE[1]:=ENDSTR;
  IF(GETARG(2,SAVEFILE,MAXSTR))THEN
    IF(DOREAD(0,SAVEFILE)=ERR)THEN
      WRITELN('?');
  MORE:=GETLINE(LIN,STDIN,MAXSTR);
  WHILE(MORE)DO BEGIN
    I:=1;
    CURSAVE:=CURLN;
    IF(GETLIST(LIN,I,STATUS)=OK)THEN BEGIN
      IF(CKGLOB(LIN,I,STATUS)=OK)THEN
        STATUS:=DOGLOB(LIN,I,CURSAVE,STATUS)
      ELSE IF(STATUS<>ERR)THEN
        STATUS:=DOCMD(LIN,I,FALSE,STATUS)
    END;
    IF(STATUS=ERR)THEN BEGIN
      WRITELN('?');
      CURLN:=MIN(CURSAVE,LASTLN)
    END
    ELSE IF(STATUS=ENDDATA)THEN
      MORE:=FALSE;
    IF(MORE)THEN
      MORE:=GETLINE(LIN,STDIN,MAXSTR)
  END;
  CLRBUF
END;




SHAR_EOF
if test 16451 -ne "`wc -c < 'chapter6.pas'`"
then
	echo shar: error transmitting "'chapter6.pas'" '(should have been 16451 characters)'
fi
fi # end of overwriting check
#	End of shell archive
exit 0