Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume2/tools/part4

Internet Message Format | 1986-11-30 | 47.1 KB

Subject: Software Tools in Pascal (Part 3 of 6)
From: ihnp4!mnetor!clewis (Chris Lewis)
Newsgroups: mod.sources
Approved: [e-mail]

Mod.sources:  Volume 2, Issue 9
Submitted by: ihnp4!mnetor!clewis (Chris Lewis)

#!/bin/sh
echo 'Start of pack.out, part 03 of 06:'
echo 'x - amatch.pascal'
sed 's/^X//' > amatch.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ AMatch -- look for match of pat[i]... at lin[offset]... }
Xsegment AMatch;
X%include swtools
X%include patdef
X%include matchdef
X%include metadef
Xfunction RAMatch (var lin: StringType; offset: Integer;
X        var pat: StringType; j: Integer): Integer;
X    forward;
Xfunction AMatch;
Xvar
X    k: Integer;
Xbegin
X    metaStackPointer := 1;
X    metaIndex := 1;
X    metaTable := nullMetaTable;
X    metaTable[0].first := offset;
X    k := RAMatch(lin, offset, pat, j);
X    metaTable[0].last := k;
X    AMatch := k;
Xend;
X{ RAMatch -- new AMatch with metas }
Xfunction RAMatch;
Xvar
X    i, k: Integer;
X    metaStackTemp: Integer;
X    done: Boolean;
Xbegin
X    done := false;
X    while (not done) and (pat[j] <> ENDSTR) do
X        if (pat[j] = CLOSURE) then begin
X            metaStackTemp := metaStackPointer;
X            j := j + PatSize(pat, j);
X            i := offset;
X            {match as many as possible }
X            while (not done) and (lin[i] <> ENDSTR) do
X                if (not OMatch(lin, i, pat, j)) then begin
X                    metaStackPointer := metaStackTemp;
X                    done := true;
X                end
X                else
X                    metaStackTemp := metaStackPointer;
X            { i points to input character that made us fail }
X            { match rest of pattern against rest of input }
X            { shrink closure by 1 after each failure }
X            done := false;
X            while (not done) and (i >= offset) do begin
X                metaStackTemp := metaStackPointer;
X                k := RAMatch(lin, i, pat, j+PatSize(pat, j));
X                if (k > 0) then { matched rest of pattern}
X                    done := true
X                else begin
X                    metaStackPointer := metaStackTemp;
X                    i := i - 1
X                end
X            end;
X            offset := k;  { if k = 0 failure, else success }
X            done := true
X        end
X        else if (not OMatch(lin, offset, pat, j)) then begin
X            offset := 0;
X            done := true
X        end
X        else  { OMatch succeeded on this pattern element }
X            j := j + PatSize(pat, j);
X    RAMatch := offset
Xend;
/
echo 'x - default.pascal'
sed 's/^X//' > default.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ Default -- set Defaulted line numbers }
Xsegment Default;
X%include swtools
X%include editcons
X%include edittype
X%include editproc
X%include editref
Xfunction Default;
Xbegin
X    if (nLines = 0) then begin
X        line1 := def1;
X        line2 := def2
X    end;
X    if (line1 > line2) or (line1 <= 0) then
X        status := ERR
X    else
X       status := OK;
X    Default := status
Xend;
/
echo 'x - eval.pascal'
sed 's/^X//' > eval.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ Eval -- expand args i..j: do built-in or push back defn }
Xsegment Eval;
X%include swtools
X%include macdefs
X%include macproc
Xprocedure Eval;
Xvar
X    argNo, k, t: Integer;
X    temp: StringType;
X    l,m,n: Integer;
Xbegin
X    t := argStk[i];
X    if traceing then begin
X        MPutStr('Traceing -$E', STDOUT);
X        case td of
X            DEFTYPE:
X                MPutStr('define($N$E', STDOUT);
X            EXPRTYPE:
X                MPutStr('expr($N$E', STDOUT);
X            SUBTYPE:
X                MPutStr('substr($N$E', STDOUT);
X            IFTYPE:
X                MPutStr('ifelse($N$E', STDOUT);
X            LENTYPE:
X                MPutStr('len($N$E', STDOUT);
X            CHQTYPE:
X                MPutStr('changeq($N$E', STDOUT)
X            otherwise
X                MPutStr('macro expansion:$N$E', STDOUT);
X        end {case};
X        for l := i + 2 to j do begin
X            CsCopy(evalStk, argStk[l], temp);
X            PutStr(temp, STDOUT);
X            PutCF(NEWLINE, STDOUT)
X        end {for};
X        MPutStr('<<<<<<$N$E', STDOUT);
X    end {if};
X
X    if (td = DEFTYPE) then
X        DoDef(argStk, i, j)
X    else if (td = EXPRTYPE) then
X        DoExpr(argStk, i, j)
X    else if (td = SUBTYPE) then
X        DoSub(argStk, i, j)
X    else if (td = IFTYPE) then
X        DoIf(argStk, i, j)
X    else if (td = LENTYPE) then
X        DoLen(argStk, i, j)
X    else if (td = CHQTYPE) then
X        DoChq(argStk, i, j)
X    else begin
X        k := t;
X        while (evalStk[k] <> ENDSTR) do
X            k := k + 1;
X        k := k - 1;   { last character of data }
X        while (k > t) do begin
X            if (evalStk[k-1] <> ARGFLAG) then
X                PutBack(evalStk[k])
X            else begin
X                argNo := Ord(evalStk[k]) - Ord(DIG0);
X                if (argNo >= 0) and (argNo < j-1) then begin
X                    CsCopy(evalStk, argStk[i+argNo+1], temp);
X                    PBStr(temp)
X                end {if};
X                k := k - 1 { skip over $ }
X            end {if};
X            k := k - 1
X        end {while};
X        if (k = t) then   { do last character }
X            PutBack(evalStk[k])
X    end {if}
Xend {Eval};
/
echo 'x - kwic.pascal'
sed 's/^X//' > kwic.pascal << '/'
X{
X    Copyright (c) 1982
X    By:    Chris Lewis
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ Kwic -- make Keyword in Context index }
Xprogram Kwic;
X%include swtools
X%include cms
Xconst
X    FOLD = DOLLAR;
Xvar
X    buf: StringType;
X    tempFile1: FileDesc;
X    tempFile2: FileDesc;
X    fileName: StringType;
X    RCode: Integer;
X{ Rotate -- output rotated lines }
Xprocedure Rotate (var buf: StringType; n: Integer);
Xvar
X    i: Integer;
Xbegin
X    i := n;
X    while (buf[i] <> NEWLINE) and (buf[i] <> ENDSTR) do begin
X        PutCF(buf[i], tempFile1);
X        i := i + 1
X    end;
X    PutCF(FOLD, tempFile1);
X    for i := 1 to n - 1 do
X        PutCF(buf[i], tempFile1);
X    PutCF(NEWLINE, tempFile1)
Xend;
X{ PutRot -- create lines with keyword at front }
Xprocedure PutRot(var buf: StringType);
Xvar
X    i: Integer;
Xbegin
X    i := 1;
X    while (buf[i] <> NEWLINE) and (buf[i] <> ENDSTR) do begin
X        if (IsAlphaNum(buf[i])) then begin
X            Rotate(buf, i); { token starts at "i" }
X            repeat
X                i := i + 1
X            until (not IsAlphaNum(buf[i]))
X        end;
X        i := i + 1
X    end
Xend;
X/* temporarily commented out until CMS cmd works
X{ UnRotate -- Unrotate lines rotated by first half of KWIC }
Xprocedure UnRotate;
Xconst
X    MAXOUT = 80;
X    MIDDLE = 40;
Xvar
X    inBuf, outBuf: StringType;
X    i, j, f: Integer;
Xbegin
X    while (GetLine(inBuf, tempFile2, MAXSTR)) do begin
X        for i := 1 to MAXOUT -1 do
X             outBuf[i] := BLANK;
X        f := StrIndex(inBuf, FOLD);
X        j := MIDDLE - 1;
X        for i := StrLength(inBuf)-1 downto f+1 do begin
X             outBuf[j] := inBuf[i];
X             j := j - 1;
X             if (j <= 0) then
X                 j := MAXOUT - 1
X        end;
X        j := MIDDLE + 3;
X        for i := 1 to f-1 do begin
X             outBuf[j] := inBuf[i];
X             j := j mod (MAXOUT - 1) + 1
X        end;
X        for j := 1 to MAXOUT - 1 do
X             if (outBuf[j] <> BLANK) then
X                 i := j;
X        outBuf[i+1] := ENDSTR;
X        PutStr(outBuf, STDOUT);
X        PutC(NEWLINE)
X    end
Xend;
X*/
X{ Main program for Kwic }
Xbegin
X    ToolInit;
X/* Cannot get CMS to call sort properly
X    CvtSST('KWIC1 TEMP A', fileName);
X    tempFile1 := FOpen(fileName, IOWRITE);
X    if tempFile1 = IOERROR then
X        Error('Cannot open first KWIC temporary');
X*/
X/* */
X    tempFile1 := STDOUT;
X/* */
X    while (GetLine(buf, STDIN, MAXSTR)) do
X        PutRot(buf);
X/*
X    Cms('EXEC OSSORT KWIC1 TEMP A KWIC2 TEMP A 1 10', RCode);
X    if RCode <> 0 then
X         Error('KWIC: BNRSORT failed');
X    CvtSST('KWIC2 TEMP A', fileName);
X    tempFile2 := FOpen(fileName, IOREAD);
X    if tempFile2 = IOERROR then
X         Error('KWIC: cannot open sorted rotated file');
X    UnRotate
X*/
Xend.
/
echo 'x - macro.pascal'
sed 's/^X//' > macro.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ Macro -- expand macros with arguments }
Xprogram Macro;
X%include swtools
X%include macdefs
X%include macproc
Xbegin
X    ToolInit;
X    InitMacro;
X    Install(defName, null, DEFTYPE);
X    Install(exprName, null, EXPRTYPE);
X    Install(subName, null, SUBTYPE);
X    Install(ifName, null, IFTYPE);
X    Install(lenName, null, LENTYPE);
X    Install(chqName, null, CHQTYPE);
X
X    cp := 0;
X    ap := 1;
X    ep := 1;
X    while (GetTok(token, MAXTOK) <> ENDFILE) do
X        if (IsLetter(token[1])) then begin
X            if (not Lookup(token, defn, tokType)) then
X                PutTok(token)
X            else begin
X                cp := cp + 1;
X                if (cp > CALLSIZE) then
X                    Error('Macro: call stack overflow');
X                callStk[cp] := ap;
X                typeStk[cp] := tokType;
X                ap := Push(ep, argStk, ap);
X                PutTok(defn);      { push definition }
X                PutChr(ENDSTR);
X                ap := Push(ep, argStk, ap);
X                PutTok(token);    { stack name }
X                PutChr(ENDSTR);
X                ap := Push(ep, argStk, ap);
X                t := GetTok(token, MAXTOK); { peek at next }
X                PBStr(token);
X                if (t <> LPAREN) then begin { add () }
X                    PutBack(RPAREN);
X                    PutBack(LPAREN);
X                end;
X                pLev[cp] := 0
X            end
X        end
X        else if (token[1] = lQuote) then begin { strip quotes }
X            nlPar := 1;
X            repeat
X                t := GetTok(token, MAXTOK);
X                if (t = rQuote) then
X                    nlPar := nlPar - 1
X                else if (t = lQuote) then
X                    nlPar := nlPar + 1
X                else if (t = ENDFILE) then
X                    Error('Macro: missing right quote');
X                if nlPar > 0 then
X                    PutTok(token)
X            until (nlPar = 0)
X        end
X        else if (cp = 0) then { not in macro at all }
X            PutTok(token)
X        else if (token[1] = LPAREN) then begin
X            if (pLev[cp] > 0) then
X                PutTok(token);
X            pLev[cp] := pLev[cp] + 1
X        end {then}
X        else if (token[1] = RPAREN) then begin
X            pLev[cp] := pLev[cp] - 1;
X            if (pLev[cp] > 0) then
X                PutTok(token)
X            else begin { end of argument list }
X                PutChr(ENDSTR);
X                Eval(argStk, typeStk[cp], callStk[cp], ap - 1);
X                ap := callStk[cp];  { pop eval stack }
X                ep := argStk[ap];
X                cp := cp - 1
X            end
X        end
X        else if (token[1] = COMMA) and (pLev[cp] = 1) then begin
X            PutChr(ENDSTR);   { new argument }
X            ap := Push(ep, argStk, ap)
X        end {then}
X        else
X            PutTok(token);   { just stack it }
X    if (cp <> 0) then
X        Error('Macro: unexpected end of input')
Xend.
/
echo 'x - makepat.pascal'
sed 's/^X//' > makepat.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ MakePat -- make pattern from arg[i], terminate at delim }
Xsegment MakePat;
X%include swtools
X%include patdef
X%include metadef
Xfunction MakePat;
Xvar
X    i,j, lastJ, lj: Integer;
X    k: Integer;
X    done, junk: Boolean;
Xbegin
X    j := 1;  { pat index}
X    i := start;  { arg index}
X    metaStackPointer := 0;
X    metaIndex := 1;
X    done := false;
X    k := start;
X    while (arg[k] <> delim) and ((k + 2) <= MAXSTR) do
X        if (arg[k] = NEWLINE) or (arg[k] = ENDSTR) then begin
X            arg[k] := delim;
X            arg[k+1] := NEWLINE;
X            arg[k+2] := ENDSTR;
X        end
X        else
X            k := k + 1;
X
X    while (not done) and (arg[i] <> delim) and
X          (arg[i] <> ENDSTR) do begin
X        lj := j;
X        if (arg[i] = ANY) then
X            junk := AddStr(ANY, pat, j, MAXPAT)
X        else if (arg[i] = BOL) and (i = start) then
X            junk := AddStr(BOL, pat, j, MAXPAT)
X        else if (arg[i] = BOM) then begin
X             junk := AddStr(BOM, pat, j, MAXPAT);
X             metaStackPointer := metaStackPointer + 1;
X             metaIndex := metaIndex + 1;
X             if (metaStackPointer > 9) or
X               (metaIndex > 9) then
X                 done := true
X        end
X        else if (arg[i] = EOM) and (metaStackPointer > 0) then begin
X            junk := AddStr(EOM, pat, j, MAXPAT);
X            metaStackPointer := metaStackPointer - 1;
X            if (metaStackPointer < 0) then
X                done := true
X        end
X        else if (arg[i] = EOL) and (arg[i+1] = delim) then
X            junk := AddStr(EOL, pat, j, MAXPAT)
X        else if (arg[i] = CCL) then
X            done := (GetCCL(arg, i, pat, j) = false)
X        else if (arg[i] = CLOSURE) and (i > start) then begin
X            lj := lastJ;
X            if (pat[lj] in [BOL, EOL, CLOSURE]) then
X                done := true             { force loop termination }
X            else
X                STClose(pat, j, lastJ)
X        end
X        else begin
X            junk := AddStr(LITCHAR, pat, j, MAXPAT);
X            junk := AddStr(Esc(arg,i), pat, j, MAXPAT)
X        end;
X        lastJ := lj;
X        if (not done) then
X            i := i + 1;
X    end;
X    if (done) or (arg[i] <> delim) or (metaStackPointer <> 0) then
X        MakePat := 0
X    else if (not AddStr(ENDSTR, pat, j, MAXPAT)) then
X        MakePat := 0                { no room}
X    else
X        MakePat := i;
Xend;
/
echo 'x - setbuf.pascal'
sed 's/^X//' > setbuf.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ SetBuf -- set Buffer and other Buffer handlers (new-free) }
Xsegment SetBuf;
X%include swtools
X%include editcons
X%include edittype
X%include editproc
X%include editref
Xconst
X    MAXLINES = 10000;
Xtype
X    BufType =    { in-memory new/free buffer handler }
X        record
X            txt: StringPtr;      { text of line }
X            mark: Boolean;      { mark for line }
X        end;
Xref OUTOFSPACE: Boolean;
Xstatic heapMark: @ Integer;
Xstatic  { This is a PRIVATE buffer }
X    intBuff: array [0..MAXLINES] of BufType;
X{ SetBuf -- (new-free) initialize line storage Buffer }
Xprocedure SetBuf;
Xvar
X    i: 0..MAXLINES;
Xbegin
X    Mark(heapMark);
X    for i := 0 to MAXLINES do
X        intBuff[i].txt := nil;
X    curLn := 0;
X    lastLn := 0
Xend;
X{ ClrBuf -- (new-free) release storage }
Xprocedure ClrBuf;
Xvar i: 0..MAXLINES;
Xbegin
X    Release(heapMark)
Xend;
X{ GetTxt -- (new-free) get text from line n into s }
Xprocedure GetTxt;
Xbegin
X    { note: the null is already there }
X    if intBuff[n].txt = nil then
X        s[1] := ENDSTR
X    else
X        s := intBuff[n].txt@;
Xend;
X{ PutTxt -- (new-free) put text from lin after curLn }
Xfunction PutTxt;
Xvar
X    sSize: Integer;
Xbegin
X    PutTxt := ERR;
X    if (lastLn < MAXLINES) then begin
X        lastLn := lastLn + 1;
X        sSize := StrLength(lin) + 1;
X        if intBuff[lastLn].txt = nil then
X            New(intBuff[lastLn].txt, sSize)
X        else if (sSize > MaxLength(intBuff[lastLn].txt@)) then begin
X            Dispose(intBuff[lastLn].txt);
X            New(intBuff[lastLn].txt, sSize)
X        end;
X        { Check for New failing }
X        if OUTOFSPACE then begin
X            intBuff[lastLn].txt := nil;  { insurance }
X            lastLn := lastLn - 1; { insurance }
X            OUTOFSPACE := false;
X            Message('out of space, write out and edit again');
X            return   { error }
X        end;
X        WriteStr(intBuff[lastLn].txt@, lin:sSize);
X        PutMark(lastLn, false);
X        BlkMove(lastLn, lastLn, curLn);
X        curLn := curLn + 1;
X        PutTxt := OK
X    end
Xend;
X{ GetMark -- get mark from nth line }
Xfunction GetMark;
Xbegin
X    GetMark := intBuff[n].mark
Xend;
X{ PutMark -- put mark m on nth line }
Xprocedure PutMark;
Xbegin
X    intBuff[n].mark := m
Xend;
X{ BlkMove -- move block of lines n1..n2 to after n3 }
Xprocedure BlkMove;
Xbegin
X    if (n3 < n1-1) then begin
X        Reverse (n3+1,n1-1);
X        Reverse (n1,n2);
X        Reverse (n3+1,n2)
X    end
X    else if (n3 > n2) then begin
X        Reverse(n1,n2);
X        Reverse(n2+1,n3);
X        Reverse(n1,n3)
X    end
Xend;
X{ Reverse -- reverse intBuff[n1]...intBuff[n2] }
Xprocedure Reverse;
Xvar temp: BufType;
Xbegin
X    while (n1 < n2) do begin
X        temp := intBuff[n1];
X        intBuff[n1] := intBuff[n2];
X        intBuff[n2] := temp;
X        n1 := n1 + 1;
X        n2 := n2 - 1
X    end
Xend;
/
echo 'x - sortdriv.pascal'
sed 's/^X//' > sortdriv.pascal << '/'
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ SortDriv -- Driver and Quick sort }
Xprogram SortDriv;
X%include SWTOOLS
X%include ioref
Xconst
X    inCoreSize = 500;
Xtype
X    LineType = StringPtr;
Xvar
X    notEof: Boolean;
X    inBuf: array [1..inCoreSize] of LineType;
X    i: Integer;
X    temp: StringType;
Xprocedure PText (nLines: Integer; outFile: FileDesc);
Xvar
X    i: Integer;
Xbegin
X    for i := 1 to nLines do
X        PutStr (inBuf[i]@, outFile);
Xend; {PText}
Xfunction GText (var nLines: Integer; inFile: FileDesc): Boolean;
Xvar
X    i: Integer;
X    temp: StringType;
Xbegin
X    nLines := 0;
X    done := (GetLine(temp, inFile, MAXSTR) = false);
X    while (not done) and (nLines < inCoreSize) do begin
X        nLines := nLines + 1;
X        inBuf[nLines]@ := Str(temp);
X        done := (GetLine(temp, inFile, MAXSTR) = false);
X    end; {while}
Xend; {GText}
X
Xprocedure QSort(l,r: integer);
X    var i,j: integer;
X        temp, hold: LineType;
Xbegin
X    i := l;
X    j := r;
X    temp := inBuf[(i+j) div 2];
X    repeat
X        while inBuf[i]@ < temp@ do
X            i := i+1;
X        while temp@ < inBuf[j]@ do
X            j := j-1;
X        if i <= j then begin
X            hold := inBuf[i];
X            inBuf[i] := inBuf[j];
X            inBuf[j] := hold;
X            i := i+1;
X            j := j-1
X        end
X    until i > j;
X    if l < j then
X        QSort(l,j);
X    if i < r then
X        QSort(i,r)
Xend {QSort} ;
Xvar
X    done: Boolean;
X    nLines: Integer;
X    high: Integer;
X    outFile: FileDesc;
Xbegin
X    ToolInit;
X    high := 0;
X    for i := 1 to inCoreSize do
X        New(inBuf[i], SizeOf(StringType));
X    repeat { initial formation of runs }
X        done := GText (nLines, STDIN);
X        QSort(1, nLines);
X        high := high + 1;
X        outFile := MakeFile(high);
X        PText (nLines, outFile);
X        Close (outFile);
X    until (done);
X    low := 1;
X    while (low < high) do begin { merge runs }
X        lim := Min(low +  MERGEORDER - 1, high);
X        GOpen (inFile, low, lim);
X        high := high + 1;
X        outFile := MakeFile(high);
X        Merge(inFile, lim-low+1, outFile);
X        Close (outFile);
X        GRemove (inFile, low, lim);
X        low := low + MERGEORDER;
X    end; {while}
X    GName (high, name) { final cleanup }
X    outFile := FOpen (name, IOREAD);
X    FCopy (outFile, STDOUT);
X    Close (outFile);
X    Remove (name);
Xend.
/
echo 'x - swtools.copy'
sed 's/^X//' > swtools.copy << '/'
X*COPY NOTICE
X{
X    Copyright (c) 1981
X    By:    Bell Telephone Laboratories, Inc. and
X        Whitesmiths, Ltd.,
X
X    This software is derived from the book
X        "Software Tools In Pascal", by
X        Brian W. Kernighan and P.J. Plauger
X        Addison-Wesley, 1981
X        ISBN 0-201-10342-7
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X*COPY SWTOOLS
X{ SWTOOLS -- Software Tools Environment Definitions }
X%print off
Xconst
X    IOERROR = 0;    { status values for open files }
X    STDIN = 1;
X    STDOUT = 2;
X    STDERR = 3;
X
X{  other IO-related stuff }
X
X    IOAVAIL = 1;
X    IOREAD  = 2;
X    IOWRITE = 3;
X    MAXOPEN = 10;
X    MAXARG  = 30;
X
X{  universal manifest constants }
X
X    ENDFILE = Chr(1);
X    ENDSTR = Chr(0);
X    MAXSTR = 200;
X
X{ EBCDIC character set }
X
X    BACKSPACE = Chr(8);
X    BACKSLASH = CHR(224);
X    TAB    = Chr(5);
X    NEWLINE = Chr(10);
X    BLANK  = ' ';
X    EXCLAM = '!';
X    QUESTION = '?';
X    DQUOTE = '"';
X    SHARP  = '#';
X    DOLLAR = '$';
X    PERCENT = '%';
X    AMPER  = '&';
X    SQUOTE = '''';
X    ACUTE  = SQUOTE;
X    LPAREN = '(';
X    RPAREN = ')';
X    STAR   = '*';
X    PLUS   = '+';
X    COMMA  = ',';
X    MINUS  = '-';
X    DASH   = MINUS;
X    PERIOD = '.';
X    SLASH  = '/';
X    COLON  = ':';
X    SEMICOL = ';';
X    LESS   = '<';
X    EQUALS = '=';
X    GREATER = '>';
X    ATSIGN = '@';
X    ESCAPE = ATSIGN;
X    LBRACK = Chr(173);
X    RBRACK = Chr(189);
X    CARET  = '^';
X    UNDERLINE = '_';
X    GRAVE  = '9C'XC;
X    LBRACE = Chr(139);
X    RBRACE = Chr(155);
X    BAR    = '|';
X    TILDE  = '~';
X    LETA = 'a';
X    LETB = 'b';
X    LETC = 'c';
X    LETD = 'd';
X    LETE = 'e';
X    LETF = 'f';
X    LETG = 'g';
X    LETH = 'h';
X    LETI = 'i';
X    LETJ = 'j';
X    LETK = 'k';
X    LETL = 'l';
X    LETM = 'm';
X    LETN = 'n';
X    LETO = 'o';
X    LETP = 'p';
X    LETQ = 'q';
X    LETR = 'r';
X    LETS = 's';
X    LETT = 't';
X    LETU = 'u';
X    LETV = 'v';
X    LETW = 'w';
X    LETX = 'x';
X    LETY = 'y';
X    LETZ = 'z';
X    BIGA = 'A';
X    BIGB = 'B';
X    BIGC = 'C';
X    BIGD = 'D';
X    BIGE = 'E';
X    BIGF = 'F';
X    BIGG = 'G';
X    BIGH = 'H';
X    BIGI = 'I';
X    BIGJ = 'J';
X    BIGK = 'K';
X    BIGL = 'L';
X    BIGM = 'M';
X    BIGN = 'N';
X    BIGO = 'O';
X    BIGP = 'P';
X    BIGQ = 'Q';
X    BIGR = 'R';
X    BIGS = 'S';
X    BIGT = 'T';
X    BIGU = 'U';
X    BIGV = 'V';
X    BIGW = 'W';
X    BIGX = 'X';
X    BIGY = 'Y';
X    BIGZ = 'Z';
X    DIG0 = '0';
X    DIG1 = '1';
X    DIG2 = '2';
X    DIG3 = '3';
X    DIG4 = '4';
X    DIG5 = '5';
X    DIG6 = '6';
X    DIG7 = '7';
X    DIG8 = '8';
X    DIG9 = '9';
X
X{ Standard types }
X
Xtype
X    FileDesc = IOERROR..MAXOPEN;
X    StringType = packed array [1..MAXSTR] of Char;
X    CharType = Char;
X
X{ Externally supplied primitive interfaces }
X
Xprocedure Error (s: String(MAXSTR));
X    external;
Xprocedure FClose (fd: FileDesc);
X    external;
Xfunction FCreate (name: StringType; mode: Integer): FileDesc;
X    external;
Xfunction FOpen (name: StringType; mode: Integer): FileDesc;
X    external;
Xprocedure FSeek (recno: Integer; fd: FileDesc);
X    external;
Xfunction GetArg (n: Integer; var str: StringType;
X        maxSize: Integer): Boolean;
X    external;
Xfunction GetC (var c: CharType): CharType;
X    external;
Xfunction GetCF (var c: CharType; fd: FileDesc): CharType;
X    external;
Xfunction GetLine (var str: StringType; fd: FileDesc;
X        maxSize: Integer): Boolean;
X    external;
Xprocedure Message (s: String(MAXSTR));
X    external;
Xfunction Nargs: Integer;
X    external;
Xprocedure PutC (c: CharType);
X    external;
Xprocedure PutCF (c: CharType; fd: FileDesc);
X    external;
Xprocedure PutStr (const str: StringType; fd: FileDesc);
X    external;
Xprocedure MPutStr (const str: StringType; fd: FileDesc);
X    external;
Xprocedure Remove (var name: StringType);
X    external;
Xprocedure SysExit (status: Integer);
X    external;
Xprocedure ToolInit;
X    external;
X
X{ Externally supplied utilities }
X
Xfunction AddStr (c: CharType; var outSet: StringType;
X        var j: Integer; maxSet: Integer): Boolean;
X    external;
Xfunction CToI (var s: StringType; var i: Integer): Integer;
X    external;
Xprocedure CvtSST (src: String(MAXSTR); var dest: StringType);
X    external;
Xprocedure CvtSTS (src: StringType; var dest: String(MAXSTR));
X    external;
Xfunction Equal (var str1, str2: StringType): Boolean;
X    external;
Xfunction Esc (var s: StringType; var i: Integer): CharType;
X    external;
Xprocedure FCopy (fin, fout: FileDesc);
X    external;
Xfunction GetFid (var line: StringType; idx: Integer;
X        var fileName: StringType): Boolean;
X    external;
Xfunction GetWord (var s: StringType; i: Integer;
X        var out: StringType): Integer;
X    external;
Xfunction IsAlphaNum (c: CharType): Boolean;
X    external;
Xfunction IsDigit (c: CharType): Boolean;
X    external;
Xfunction IsLetter (c: CharType): Boolean;
X    external;
Xfunction IsLower (c: CharType): Boolean;
X    external;
Xfunction IsUpper (c: CharType): Boolean;
X    external;
Xfunction IToC (n: Integer; var s: StringType; i: Integer): Integer;
X    external;
Xfunction MustOpen (var fName: StringType; fMode: Integer): FileDesc;
X    external;
Xprocedure PutDec (n, w: Integer);
X    external;
Xprocedure SCopy (var src: StringType; i: Integer;
X        var dest: StringType; j: Integer);
X    external;
Xfunction StrIndex (const s: StringType; c: CharType): Integer;
X    external;
Xfunction StrLength (const s: StringType): Integer;
X    external;
Xprocedure ProgExit (const returnCode: Integer); external;
X%print on
X*COPY EDITCONS
X{ EditCons -- const declarations for edit }
Xconst
X    CURLINE = PERIOD;
X    LASTLINE = DOLLAR;
X    SCAN = SLASH;
X    BACKSCAN = BACKSLASH;
X    ACMD = LETA;
X    CCMD = LETC;
X    DCMD = LETD;
X    ECMD = LETE;
X    EQCMD = EQUALS;
X    FCMD = LETF;
X    GCMD = LETG;
X    ICMD = LETI;
X    MCMD = LETM;
X    KCMD = LETK;
X    OCMD = LETO;
X    PCMD = LETP;
X    LCMD = LETL;
X    QCMD = LETQ;
X    RCMD = LETR;
X    SCMD = LETS;
X    WCMD = LETW;
X    XCMD = LETX;
X    promptFlag = 0;
X    verboseFlag = 1;
X    noMetaFlag = 2;
X    { insert more option flags here }
X    numFlag = 15;
X*COPY EDITTYPE
X{ EditType -- types for in-memory version of edit }
Xtype
X    STCode = (ENDDATA, ERR, OK);      { status returns }
X*COPY EDITPROC
X{ EditProc -- routine declarations for SW editor }
Xfunction GetList (var lin: StringType; var i: Integer;
X                  var status: STCode): STCode; external;
Xfunction GetOne (var lin: StringType; var i, num: Integer;
X                 var status: STCode): STCode; external;
Xfunction GetNum (var lin: StringType; var i, num: integer;
X                 var status: STCode): STCode; external;
Xfunction OptPat (var lin: StringType; var i: Integer): STCode; external;
Xfunction PatScan (way: CharType; var n: Integer): STCode; external;
Xfunction NextLn (n: Integer): Integer; external;
Xfunction PrevLn (n: Integer): Integer; external;
Xfunction Default (def1, def2: Integer;
X                  var status: STCode): STCode; external;
Xfunction DoPrint (n1, n2: Integer): STCode; external;
Xfunction DoLPrint (n1, n2: Integer): STCode; external;
Xfunction DoCmd (var lin: StringType; var i: Integer;
X                glob: Boolean; var status: STCode): STCode; external;
Xfunction Append (line: Integer; glob: Boolean): STCode; external;
Xprocedure BlkMove (n1, n2, n3: Integer); external;
Xprocedure Reverse (n1, n2: Integer); external;
Xprocedure GetTxt (n: Integer; var s: StringType); external;
Xprocedure SetBuf; external;
Xfunction PutTxt (var lin: StringType): STCode; external;
Xfunction CkP (var lin: StringType; i: Integer;
X              var pFlag: Boolean; var status: STCode):
X              STCode; external;
Xfunction LnDelete (n1, n2: Integer; var status: STCode):
X              STCode; external;
Xfunction Move (line3: Integer): STCode; external;
Xfunction Kopy (line3: Integer): STCode; external;
Xfunction GetRHS (var lin: StringType; var i: Integer;
X                 var sub: StringType; var gFlag: Boolean):
X                 STCode; external;
Xfunction SubSt (var sub: StringType; gFlag, glob: Boolean):
X                STCode; external;
Xprocedure SkipBl (var s: StringType; var i: Integer);
X    external;
Xfunction GetFn(var lin: StringType; var i:Integer;
X               var fil: StringType): STCode; external;
Xfunction DoRead (n: integer; var fil: StringType): STCode; external;
Xfunction DoWrite (n1, n2: Integer; var fil: StringType): STCode;
X                  external;
Xfunction CkGlob (var lin: StringType; var i: Integer;
X                 var status: STCode): STCode; external;
Xfunction DoGlob (var lin: StringType; var i, curSave: Integer;
X                 var status: STCode): STCode; external;
Xprocedure ClrBuf; external;
Xfunction GetMark(n: Integer): Boolean; external;
Xprocedure PutMark(n: Integer; m: Boolean); external;
Xfunction DoOption(var lin: STringType; var i: Integer):
X    STCode; external;
Xfunction OptIsOn(flag: promptFlag..numFlag): Boolean; external;
X*COPY IODEF
Xtype
X    IOBlock =
X        record
X            fileVar: Text;
X            mode: IOERROR..IOWRITE
X        end;
Xfunction FDAlloc: Integer; External;
X*COPY IOREF
X{ GlobRef -- standard global references (IO support mainly) }
X%include iodef
Xref openList: array [FileDesc] of IOBlock;
Xref ERRORIO: Boolean;
Xref ATTENTION: Boolean;
Xref cmdLin: StringType;
Xref cmdArgs: 0..MAXARG;
Xref cmdIdx: array [1..MAXARG] of 1..MAXSTR;
X*COPY EDITREF
X{ EditRef -- external reference definitions for SW editor }
Xref
X    line1: Integer;    { first line number }
X    line2: Integer;    { second line number }
X    nLines: Integer;   { # of lines specified }
X    curLn: Integer;    { current line }
X    lastLn: Integer;   { last line in buffer }
X    pat: StringType;   { pattern string }
X    lin: StringType;   { input line }
X    saveFile: StringType;  { current remembered file name }
X*COPY MATCHDEF
X{ MatchDef -- definitions of match and sub-fcns }
Xfunction PatSize (var pat: StringType; n: Integer): Integer;
X    external;
Xfunction OMatch (var lin: StringType; var i: Integer;
X                 var pat: StringType; j: Integer): Boolean;
X    external;
Xfunction Locate (c: CharType; var pat: StringType;
X                 offset: Integer): Boolean;
X    external;
Xfunction Match (var lin, pat: StringType): Boolean;
X    external;
Xfunction AMatch (var lin: StringType; offset: Integer;
X        var pat: StringType; j: Integer): Integer;
X    external;
X*COPY PATDEF
X{ PatDef -- pattern constant declarations for GetPat }
Xconst
X    MAXPAT = MAXSTR;
X    CLOSIZE = 1;   { size of closure entry }
X    BOL = PERCENT;
X    EOL = DOLLAR;
X    ANY = QUESTION;
X    CCL = LBRACK;
X    CCLEND = RBRACK;
X    NEGATE = CARET;
X    NCCL = SHARP;{ cannot be the same as NEGATE }
X    LITCHAR = LETC;
X    NCHAR = EXCLAM;
X    CLOSURE = STAR;
Xfunction GetCCL (var arg: StringType; var i: Integer;
X            var pat: StringType; var j: Integer)
X            :Boolean;
X    external;
Xprocedure StClose(var pat: StringType; var j: Integer;
X            lastJ: Integer);
X    external;
Xfunction GetPat (var arg, pat: StringType): Boolean;
X    external;
Xfunction MakePat (var arg: StringType; start: Integer;
X        delim: CharType; var pat: StringType): Integer;
X    external;
Xprocedure DoDash (delim: CharType; var src: StringType;
X        var i: Integer; var dest: StringType;
X        var j: Integer; maxSet: Integer);
X    external;
Xfunction MakeSet (var inSet: StringType; k: Integer;
X        var outSet: StringType; maxSet: Integer): Boolean;
X    external;
X*COPY SUBDEF
X{ subdef -- definitions of substitution routines }
Xconst
X    DITTO = Chr(255);
Xprocedure SubLine (var lin, pat, sub: StringType);
X    external;
Xprocedure CatSub (var lin: StringType; s1,s2: Integer;
X        var sub: StringType; var new: StringType;
X        var k: Integer; maxNew: Integer);
X    external;
Xprocedure PutSub(var lin: StringType; s1, s2: Integer;
X                 var sub: StringType);
X    external;
Xfunction MakeSub (var arg: StringType; from: Integer;
X        delim: CharType; var sub: StringType): Integer;
X    external;
Xfunction GetSub (var arg, sub: StringType): Boolean;
X    external;
X*COPY DEFVAR
X{ DefVar -- var declarations for define }
Xdef
X    hashTab:    array [1..HASHSIZE] of NDPtr;
X    NDTable:    CharBuf;
X    nextTab:    CharPos;        { first free position in NDTable }
X    buf:        array [1..BUFSIZE] of CharType; { for push back }
X    bp:         0..BUFSIZE;     { next available character; init = 0 }
X    defn:   StringType;
X    token:  StringType;
X    tokType:    STType;     { type returned by lookup }
X    defName:    StringType; { value is 'define' }
X    null:       StringType; { value is '' }
X*COPY DEFDEF
X{ DefDef  -- definitions needed for define }
X{ DefCons -- const declarations for define }
Xconst
X    BUFSIZE     = 500;      { size of push back buffer }
X    MAXCHARS    = 5000;     { size of name-defn table }
X    MAXDEF      = MAXSTR;   { max chars in a defn }
X    MAXTOK      = MAXSTR;   { max chars in a token }
X    HASHSIZE    = 53;       { size of hash table }
X{ DefType -- type declarations for define }
Xtype
X    CharPos     = 1..MAXCHARS;
X    CharBuf     = array [1..MAXCHARS] of CharType;
X    STType      = (DEFTYPE, MACTYPE);       { symbol table types }
X    NDPtr       = -> NDBlock;       { pointer to name-defn block }
X    NDBlock     =
X        record
X            name:       CharPos;
X            defn:       CharPos;
X            kind:       STType;
X            nextPtr:    NDPtr;
X        end;
X*COPY DEFPROC
X{ DefProc -- procedures needed for define }
Xprocedure CSCopy (var cb: CharBuf; i: CharPos;
X        var s: StringType);
X    external;
Xprocedure SCCopy (var s: StringType; var cb: CharBuf;
X        i: CharPos);
X    external;
Xprocedure PutBack (c: CharType);
X    external;
Xfunction GetPBC (var c: CharType): CharType;
X    external;
Xprocedure PBStr (var s: StringType);
X    external;
Xfunction GetTok (var token: StringType; tokSize: Integer): CharType;
X    external;
Xprocedure GetDef (var token: StringType; tokSize: Integer;
X        var defn: StringType; defSize: Integer);
X    external;
Xprocedure InitHash;
X    external;
Xfunction Hash (var name: StringType): Integer;
X    external;
Xfunction HashFind (var name: StringType): NDPtr;
X    external;
Xprocedure Install (var name, defn: StringType; t: STType);
X    external;
Xfunction Lookup (var name, defn: StringType; var t: STType): Boolean;
X    external;
Xprocedure InitDef;
X    external;
X*COPY DEFREF
Xdef
X    hashTab:    array [1..HASHSIZE] of NDPtr;
X    NDTable:    CharBuf;
X    nextTab:    CharPos;        { first free position in NDTable }
X    buf:        array [1..BUFSIZE] of CharType; { for push back }
X    bp:         0..BUFSIZE;     { next available character; init = 0 }
X    defn:   StringType;
X    token:  StringType;
X    tokType:    STType;     { type returned by lookup }
X    defName:    StringType; { value is 'define' }
X    null:       StringType; { value is '' }
X*COPY METADEF
X{ MetaDef -- definitions for Meta bracket implementation }
Xconst
X    BOM = LBRACE;  { start of meta bracket }
X    EOM = RBRACE;  { end of meta bracket }
Xtype
X    MetaIndexType = Integer;
X    MetaElementType =
X        record
X            first: Integer;
X            last: Integer;
X        end;
X    MetaTableType = array [0..9] of MetaElementType;
X    MetaStackType = array [0..9] of MetaIndexType;
Xdef
X    metaIndex: MetaIndexType;
X    metaTable: MetaTableType;
X    nullMetaTable: MetaTableType;
X    metaStack: MetaStackType;
X    metaStackPointer: Integer;
X*COPY CHARDEF
Xconst
X    ChLetter = 0;
X    ChLower  = 1;
X    ChUpper  = 2;
X    ChDigit  = 3;
X    ChSpecial = 4;
Xtype
X    ChEntry = packed set of 0..7;
X    ChTable = array [0..255] of ChEntry;
Xdef
X    CharTable: ChTable;
Xfunction CharClass(const tIndex: CharType): ChEntry; external;
X*COPY MACPROC
X{ MacProc -- procedures needed for define }
Xprocedure CSCopy (var cb: CharBuf; i: CharPos;
X        var s: StringType);
X    external;
Xprocedure SCCopy (var s: StringType; var cb: CharBuf;
X        i: CharPos);
X    external;
Xprocedure PutBack (c: CharType);
X    external;
Xfunction GetPBC (var c: CharType): CharType;
X    external;
Xprocedure PBStr (var s: StringType);
X    external;
Xfunction GetTok (var token: StringType; tokSize: Integer): CharType;
X    external;
Xprocedure GetDef (var token: StringType; tokSize: Integer;
X        var defn: StringType; defSize: Integer);
X    external;
Xprocedure InitHash;
X    external;
Xfunction Hash (var name: StringType): Integer;
X    external;
Xfunction HashFind (var name: StringType): NDPtr;
X    external;
Xprocedure Install (var name, defn: StringType; t: STType);
X    external;
Xfunction Lookup (var name, defn: StringType; var t: STType): Boolean;
X    external;
Xprocedure PutTok(var s: StringType);
X    external;
Xprocedure PutChr(c: CharType);
X    external;
Xprocedure InitMacro;
X    external;
Xfunction Push (ep: Integer; var argStk: PosBuf;
X        ap: Integer): Integer;
X    external;
Xprocedure Eval(var argStk: PosBuf; td: StType;
X        i,j: Integer);
X    external;
Xprocedure DoDef (var argStk: PosBuf; i,j: Integer);
X    external;
Xprocedure DoIf(var argStk: PosBuf; i,j: Integer);
X    external;
Xprocedure DoExpr(var argStk: PosBuf; i,j: Integer);
X    external;
Xfunction Expr(var s: StringType; var i: Integer): Integer;
X    external;
Xfunction Term(var s: StringType; var i: Integer): Integer;
X    external;
Xfunction Factor(var s: StringType; var i: Integer): Integer;
X    external;
Xfunction GnbChar(var s: StringType; var i: Integer): CharType;
X    external;
Xprocedure DoLen(var argStk: PosBuf; i,j: Integer);
X    external;
Xprocedure DoSub(var argStk: PosBuf; i,j: Integer);
X    external;
Xprocedure DoChq(var argStk: PosBuf; i,j: Integer);
X    external;
Xprocedure PBNum(n: Integer);
X    external;
X*COPY MACDEFS
X{ Macdefs -- all definitions for Macro }
Xconst
X    BUFSIZE = 1000;       { size of pushback buffer }
X    MAXCHARS = 5000;      { size of name-defn table }
X    MAXPOS = 500;
X    CALLSIZE = MAXPOS;
X    ARGSIZE = MAXPOS;
X    EVALSIZE = MAXCHARS;
X    MAXDEF = MAXSTR;      { max chars in a defn }
X    MAXTOK = MAXSTR;      { max length of a token }
X    HASHSIZE = 53;        { size of hash table }
X    ARGFLAG = DOLLAR;     { macro invocation character }
X
X{ MacType -- type declarations for Macro }
Xtype
X    CharPos = 1..MAXCHARS;
X    CharBuf = packed array [1..MAXCHARS] of CharType;
X    PosBuf = packed array [1..MAXPOS] of CharPos;
X    Pos = 0..MAXPOS;
X    StType = (DEFTYPE, MACTYPE, IFTYPE, SUBTYPE,
X        EXPRTYPE, LENTYPE, CHQTYPE); { symbol table types }
X    NdPtr = ->NdBlock;
X    NdBlock =
X        record
X            name: CharPos;
X            defn: CharPos;
X            kind: StType;
X            nextPtr: NdPtr;
X        end {record};
X{ Macvar -- def declarations for macro }
Xdef
X    traceing: Boolean;
X    buf: packed array [1..BUFSIZE] of CharType; { for pushback }
X    bp: 0..BUFSIZE;
X    hashTab: array [1..HASHSIZE] of NdPtr;
X    ndTable: CharBuf;
X    nextTab: CharPos;    { first free position in ndTable }
X    callStk: PosBuf;
X    cp: Pos;             { current call stack position }
X    typeStk: array [1..CALLSIZE] of StType; { type }
X    pLev: array [1..CALLSIZE] of Integer; { paren level }
X    argStk: PosBuf;      { argument stack for this call }
X    ap: Pos;             { current argument position }
X    evalStk: CharBuf;    { evaluation stack }
X    ep: CharPos;         { first character unused in evalStk }
X    { builtins }
X    defName: StringType; { 'define' }
X    exprName: StringType;{ 'expr' }
X    subName: StringType; { 'substr' }
X    ifName: StringType;  { 'ifelse' }
X    lenName: StringType; { 'len' }
X    chqName: StringType; { 'changeq' }
X    null: StringType;    { value is '' }
X    lQuote: CharType;    { left quote character }
X    rQuote: CharType;    { right quote character }
X
X    defn: StringType;
X    token: StringType;
X    tokType: StType;
X    t: CharType;
X    nlPar: Integer;
/
echo 'x - toolinit.pascal'
sed 's/^X//' > toolinit.pascal << '/'
X{
X    Copyright (c) 1982
X    By:    Chris Lewis
X
X    Right is hereby granted to freely distribute or duplicate this
X    software, providing distribution or duplication is not for profit
X    or other commerical gain and that this copyright notice remains
X    intact.
X}
X{ ToolInit -- (CMS) standard program prologue }
Xsegment ToolInit;
X%include swtools
X%include iodef
Xdef openList: array [FileDesc] of IOBlock;
Xdef cmdLin: StringType;
Xdef cmdArgs: 0..MAXARG;
Xdef cmdIdx: array [1..MAXARG] of 1..MAXSTR;
Xdef termInput: Boolean;
Xref ERRORIO: Boolean;
Xvalue
X    termInput := false;
Xprocedure ToolInit;
Xvar
X    t: 1..MAXSTR;
X    i: FileDesc;
X    idx: 1..MAXSTR;
X    delim: CharType;
X    PARMSTRING: String(MAXSTR);
X    fileName: StringType;
X    cmdLength: 0..MAXSTR;
X    redirIn: Boolean;
X    j: 1..MAXSTR;
X    dummy: StringType;
X    okay: Boolean;
X    tempArgs: 0..MAXARG;
X    XFileName: String(MAXSTR);
X    k: 0..MAXSTR;
X    nextChar: 1..MAXSTR;
Xbegin
X    TermIn(input);
X    TermOut(output);
X    for i := STDIN to MAXOPEN do
X        openList[i].mode := IOAVAIL;
X    openList[STDERR].mode := IOWRITE;
X    TermOut(openList[STDERR].fileVar);
X    PARMSTRING := PARMS;
X    if (Length(PARMSTRING) >= 1) and (PARMSTRING[1] = STAR) then begin
X        WriteLn('Input Command Parameters:');
X        ReadLn(PARMSTRING);
X        PARMSTRING := PARMSTRING || SubStr(PARMS, 2, Length(PARMS)-1)
X    end;
X    for idx := 1 to Length(PARMSTRING) do
X        cmdLin[idx] := PARMSTRING[idx];
X    cmdLin[Length(PARMSTRING) + 1] := NEWLINE;
X    cmdLin[Length(PARMSTRING) + 2] := ENDSTR;
X    idx := 1;
X    cmdArgs := 0;
X    while ((cmdLin[idx] <> ENDSTR) and
X      (cmdLin[idx] <> NEWLINE)) do begin
X        while (cmdLin[idx] = BLANK) do
X            idx := idx + 1;
X        if (cmdLin[idx] <> NEWLINE) then begin
X            delim := BLANK;
X            cmdArgs := cmdArgs + 1;
X            if (cmdLin[idx] = SQUOTE) or
X              (cmdLin[idx] = DQUOTE) then begin
X                cmdIdx[cmdArgs] := idx + 1;
X                delim := cmdLin[idx];
X                idx := idx + 1
X            end
X            else
X                cmdIdx[cmdArgs] := idx;
X            while ((cmdLin[idx] <> NEWLINE) and
X              (cmdLin[idx] <> delim)) do
X                idx := idx + 1;
X            cmdLin[idx] := ENDSTR;
X            idx := idx + 1;
X        end
X    end;
X    j := 1;
X    tempArgs := cmdArgs;
X    while (j <= cmdArgs) do begin
X        okay := GetArg(j, dummy, MAXSTR);
X        j := j + 1;
X        if (dummy[1] = LESS) or (dummy[1] = GREATER) then begin
X            if dummy[1] = LESS then
X                redirIn := true
X            else
X                redirIn := false;
X            SCopy(dummy, 2, fileName, 1);
X            nextChar := StrLength(fileName) + 1;
X            tempArgs := tempArgs - 1;
X            k := j;
X            while (k <= cmdArgs) do begin
X                okay := GetArg(k, dummy, MAXSTR);
X                k := k + 1;
X                if okay and (dummy[1] <> LESS) and
X                  (dummy[1]<> GREATER) then begin
X                    tempArgs := tempArgs - 1;
X                    fileName[nextChar] := BLANK;
X                    nextChar := nextChar + 1;
X                    SCopy(dummy, 1, fileName, nextChar);
X                    nextChar := StrLength(fileName) + 1;
X                    j := j + 1;
X                end
X                else
X                    k := cmdArgs + 1;
X            end;
X            t := 1;
X            okay := GetFid(fileName, t, fileName);
X            if not okay then
X                Error('Bad redirection file name');
X            CvtSTS(fileName, XFileName);
X            if redirIn then begin
X                 openList[STDIN].mode := IOREAD;
X                 Reset(openList[STDIN].fileVar, 'NAME=' ||
X                     XFileName);
X                 termInput := false;
X                 if ERRORIO then begin
X                     openList[STDIN].mode := IOAVAIL;
X                     Error('Cannot open STDIN file');
X                     ERRORIO := false
X                 end
X            end
X            else begin
X                 openList[STDOUT].mode := IOWRITE;
X                 Remove(fileName);
X                 ReWrite(openList[STDOUT].fileVar,
X                     'LRECL=1000,NAME=' || XFileName);
X                 if ERRORIO then begin
X                     openList[STDOUT].mode := IOAVAIL;
X                     ERRORIO := false
X                 end
X            end
X        end
X    end;
X    cmdArgs := tempArgs;
X    if openList[STDIN].mode = IOAVAIL then begin
X        TermIn(openList[STDIN].fileVar);
X        openList[STDIN].mode := IOREAD;
X        termInput := true;
X    end;
X    if openList[STDOUT].mode = IOAVAIL then begin
X        TermOut(openList[STDOUT].fileVar);
X        openList[STDOUT].mode := IOWRITE;
X    end;
Xend;
/
echo 'Part 03 of pack.out complete.'
exit