Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Posting-Version: version B 2.10.2 9/3/84; site panda.UUCP
Path: utzoo!decvax!bellcore!petrus!scherzo!allegra!mit-eddie!genrad!panda!sources-request
From: sources-request@panda.UUCP
Newsgroups: mod.sources
Subject: Software Tools in Turbo Pascal (Part 2 of 2)
Message-ID: <1060@panda.UUCP>
Date: Sun, 3-Nov-85 07:30:14 EST
Article-I.D.: panda.1060
Posted: Sun Nov  3 07:30:14 1985
Date-Received: Mon, 4-Nov-85 02:45:55 EST
Sender: jpn@panda.UUCP
Lines: 2753
Approved: jpn@panda.UUCP

Mod.sources:  Volume 3, Issue 34
Submitted by: talcott!cmcl2!lanl!jp (James Potter)



#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#	chapter1.pas
#	chapter2.pas
#	chapter3.pas
#	chapter4.pas
#	chapter5.pas
#	chapter6.pas
# This archive created: Fri Nov  1 20:12:01 1985
export PATH; PATH=/bin:$PATH
echo shar: extracting "'chapter1.pas'" '(2054 characters)'
if test -f 'chapter1.pas'
then
	echo shar: will not over-write existing file "'chapter1.pas'"
else
cat << \SHAR_EOF > 'chapter1.pas'
{chapter1.pas}

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

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

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

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


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

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

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

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

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

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

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




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

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

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

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

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


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

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

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

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


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



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

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

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

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



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

VAR J:INTEGER;

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

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

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




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

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

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

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

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

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

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

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

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

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

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

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

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


PROCEDURE INCLUDE;
VAR
  INCL:XSTRING;

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

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

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

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

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


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

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

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

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


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

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

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

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

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


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

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


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


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

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

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

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


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


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



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

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

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

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

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

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

      

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

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


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

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


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

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

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


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

  MAKEFILE:=MUSTCREATE(NAME,IOWRITE)
END;

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

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

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

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

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

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


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

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

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

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

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

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

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

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





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

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

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

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

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

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

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

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

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

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

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

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

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

FUNCTION AMATCH;


VAR I,K:INTEGER;
   DONE:BOOLEAN;


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


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

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

VAR
  I,POS:INTEGER;

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




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

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

  

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


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

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

  

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

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

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

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


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

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

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



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

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

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

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

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

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

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







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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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




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