Software Tools in Pascal (Part 3 of 6)
sources-request at genrad.UUCP
sources-request at genrad.UUCP
Sat Jul 13 09:12:48 AEST 1985
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
More information about the Mod.sources
mailing list