Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!cmcl2!rna!rocky2!reintom
From: reintom@rocky2.UUCP (Tom Reingold)
Newsgroups: net.sources
Subject: Software Tools in Pascal for Turbo Pascal (part 1/3)
Message-ID: <262@rocky2.UUCP>
Date: Wed, 1-Oct-86 01:00:39 EDT
Article-I.D.: rocky2.262
Posted: Wed Oct  1 01:00:39 1986
Date-Received: Fri, 3-Oct-86 00:47:29 EDT
Organization: Rockefeller Univ., N.Y.C. 10021
Lines: 1543

#! /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
# This archive created: Thu Sep 18 14:16:10 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
#	End of shell archive
exit 0