Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume2 / tools / part5 < prev next >

Wrap

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

Subject: Software Tools in Pascal (Part 4 of 6) From: ihnp4!mnetor!clewis (Chris Lewis) Newsgroups: mod.sources Approved: john@genrad.UUCP Mod.sources: Volume 2, Issue 10 Submitted by: ihnp4!mnetor!clewis (Chris Lewis) #!/bin/sh echo 'Start of pack.out, part 04 of 06:' echo 'x - ckglob.pascal' sed 's/^X//' > ckglob.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{ CkGlob -- if global prefix, mark lines to be affected } Xsegment CkGlob; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref X%include matchdef Xfunction CkGlob; Xvar X n: Integer; X gFlag: Boolean; X temp: StringType; Xbegin X if (lin[i] <> GCMD) and (lin[i] <> XCMD) then X status := ENDDATA X else begin X gFlag := (lin[i] = GCMD); X i := i + 1; X if (OptPat(lin, i) = ERR) then X status := ERR X else if (Default(1, lastLn, status) <> ERR) then begin X i := i + 1; { mark affected lines } X for n := line1 to line2 do begin X GetTxt(n, temp); X PutMark(n, (Match(temp, pat) = gFlag)) X end; X for n := 1 to line1-1 do { erase other marks } X PutMark(n, false); X for n := line2+1 to lastLn do X PutMark(n, false); X status := OK X end X end; X CkGlob := status Xend; / echo 'x - define.pascal' sed 's/^X//' > define.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{ Define -- simple string replacement macro processor } Xprogram Define; X%include swtools X%include defdef X%include defvar X%include defproc X{ InitDef -- initialize variables for define } Xprocedure InitDef; Xbegin X CvtSST('define', defName); X bp := 0; { push back buffer pointer } X InitHash Xend; Xbegin X ToolInit; X null[1] := ENDSTR; X InitDef; X Install(defName, null, DEFTYPE); X while (GetTok(token, MAXTOK) <> ENDFILE) do X if (not IsLetter(token[1])) then X PutStr(token, STDOUT) X else if (not Lookup(token, defn, tokType)) then X PutStr(token, STDOUT) { undefined } X else if (tokType = DEFTYPE) then begin { defn } X GetDef(token, MAXTOK, defn, MAXDEF); X Install(token, defn, MACTYPE) X end X else X PBStr(defn) { push back replacement string } Xend. / echo 'x - dodash.pascal' sed 's/^X//' > dodash.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{ DoDash -- expand set at src(i) into dest(j), stop at delim } Xsegment DoDash; X%include swtools X%include patdef Xprocedure DoDash; Xvar X k: CharType; X junk: Boolean; Xbegin X while (src[i] <> delim) and (src[i] <> ENDSTR) do begin X if (src[i] = ESCAPE) then X junk := AddStr(Esc(src,i), dest, j, maxSet) X else if (src[i] <> DASH) then X junk := AddStr(src[i], dest, j, maxSet) X else if (j <= 1) or (src[i+1] = ENDSTR) then X junk := AddStr(DASH, dest, j, maxSet) { literal -} X else if IsAlphaNum(src[i-1]) and X IsAlphaNum(src[i+1]) and X (src[i-1] <= src[i+1]) then begin X for k := Succ(src[i-1]) to src[i+1] do X { the following obscenity is due to EBCDIC "holes" } X if IsAlphaNum(k) then begin X junk := AddStr(k, dest, j, maxSet); X end; X i := i + 1 X end X else X junk := AddStr(DASH, dest, j, maxSet); X i := i + 1 X end Xend; / echo 'x - dooption.pascal' sed 's/^X//' > dooption.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{ DoOption -- build options for the swtools editor } Xsegment DoOption; X%include swtools X%include editcons X%include edittype X%include editproc Xdef X optionFlags: set of promptFlag..numFlag; Xvalue X optionFlags := []; Xfunction DoOption; Xvar X optSel: promptFlag..numFlag; X setting: Boolean; Xbegin X DoOption := OK; { error handling done here } X i := i + 1; X if (lin[i] = NEWLINE) or (lin[i+1] = NEWLINE) then X Message('Bad option string') X else begin X if lin[i+1] in [LETS, BIGS] then setting := true X else if lin[i+1] in [LETC, BIGC] then setting := false X else begin X Message('You must [s]et or [c]lear the option'); X return X end; X case lin[i] of X LETP, BIGP: X optSel := promptFlag; X LETM, BIGM: X optSel := noMetaFlag; X LETV, BIGV: X optSel := verboseFlag; X LETN, BIGN: X optSel := numFlag X otherwise X begin X Message('You gave an illegal option'); X Message('available options are:'); X Message('ps/pc: turn on/off prompting'); X Message('vs/vc: turn on/off verbose mode'); X Message('ns/nc: turn on/off line numbers'); X Message('ms/mc: turn on/off stupid matching'); X return X end X end; X if setting then X optionFlags := optionFlags + [optSel] X else X optionFlags := optionFlags - [optSel] X end Xend; Xfunction OptIsOn; Xbegin X if flag in optionFlags then OptIsOn := true X else OptIsOn := false Xend; / echo 'x - doread.pascal' sed 's/^X//' > doread.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{ DoRead -- read "fil" after line n } Xsegment DoRead; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref Xfunction DoRead; Xvar X count: Integer; X t: Boolean; X stat: STCode; X fd: FileDesc; X inLine: StringType; Xbegin X fd := FOpen(fil, IOREAD); X if (fd = IOERROR) then X stat := ERR X else begin X curLn := n; X stat := OK; X count := 0; X repeat X t := GetLine(inLine, fd, MAXSTR); X if (t) then begin X stat := PutTxt(inLine); X if (stat <> ERR) then X count := count + 1 X end X until (stat <> OK) or (t = false); X FClose(fd); X PutDec(count, 1); X PutC(NEWLINE); X end; X DoRead := stat Xend; / echo 'x - dosub.pascal' sed 's/^X//' > dosub.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{ DoSub -- Select substring } Xsegment DoSub; X%include swtools X%include macdefs X%include macproc Xprocedure DoSub; Xvar X ap, fc, k, nc: Integer; X temp1, temp2: StringType; Xbegin X if (j - i >= 3) then begin X if (j - i < 4) then X nc := MAXTOK X else begin X CsCopy(evalStk, argStk[i+4], temp1); X k := 1; X nc := Expr(temp1, k) X end {if}; X CsCopy(evalStk, argStk[i+3], temp1); { origin } X ap := argStk[i+2]; { target string } X k := 1; X fc := ap + Expr(temp1, k) - 1; { first char } X CsCopy(evalStk, ap, temp2); X if (fc >= ap) and (fc < ap + StrLength(temp2)) then begin X CsCopy(evalStk, fc, temp1); X for k := fc + Min(nc, StrLength(temp1))-1 downto fc do X PutBack(evalStk[k]) X end {if} X end {if} Xend {DoSub}; / echo 'x - expand.pascal' sed 's/^X//' > expand.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{ Expand -- Expand a file by a specified factor } Xprogram Expand; X%include swtools Xconst maxWidth = 2000; Xvar X arguments: StringType; X outBuffer: array [1..maxWidth] of Char; X inPtr: Integer; X anchor: Integer; X i: Integer; X factor: Integer; X index: Integer; X j: Integer; Xbegin X ToolInit; X index := 1; X if GetArg(1, arguments, MAXSTR) then begin X factor := CToI(arguments, index); X if factor = 0 then X Error('Argument to Expand should be numeric, > 0'); X end X else X factor := 1; X while true do begin X inPtr := 1; X { read an input line, expanding on the fly } X while (GetC(outBuffer[inPtr]) <> ENDFILE) do begin X if outBuffer[inPtr] = NEWLINE then leave; X anchor := inPtr; X for j := 1 to factor - 1 do begin X inPtr := inPtr + 1; X outBuffer[inPtr] := outBuffer[anchor]; X end; {for} X inPtr := inPtr + 1; X end; {while} X if outBuffer[inPtr] = ENDFILE then leave; X { output expanded array twice } X for j := 1 to factor do X for i := 1 to inPtr do X PutC(outBuffer[i]); X end; {while} Xend. {Expand} / echo 'x - fopen.pascal' sed 's/^X//' > fopen.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{ FOpen -- open a file } Xsegment FOpen; X%include swtools X%include cms X%include ioref Xfunction FOpen; Xvar X returnCode: Integer; X cmsString: String(MAXSTR); X sName: String(MAXSTR); X f: FileDesc; X i: 1..MAXSTR; X fixedName: StringType; Xbegin X if mode = IOREAD then begin X cmsString := 'STATE '; X for i := 1 TO StrLength(name) do X if name[i] in [NEWLINE, PERIOD] then X cmsString := cmsString || Str(' ') X else X cmsString := cmsString || Str(name[i]); X Cms(cmsString, returnCode); X if returnCode <> 0 then begin X FOpen := IOERROR; X return X end; X end; X i := 1; X if (not GetFid(Name, i, fixedName)) then X Error('Bad file name'); X CvtSTS(fixedName, sName); X f := FDAlloc; X if f = IOERROR then X Error('Out of file descriptors') X else begin X openList[f].mode := mode; X if mode = IOREAD then X Reset(openList[f].fileVar, 'name=' || sName) X else begin X Remove(fixedName); X ReWrite(openList[f].fileVar, 'name=' || sName); X end; X if ERRORIO then begin X openList[f].mode := IOAVAIL; X f := IOERROR; X ERRORIO := false; X end X end; X FOpen := f Xend; / echo 'x - getdef.pascal' sed 's/^X//' > getdef.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{ GetDef -- get name and definition } Xsegment GetDef; X%include swtools X%include defdef X%include defref X%include defproc Xprocedure GetDef; Xvar X i, nlPar: Integer; X c: CharType; Xbegin X token[1] := ENDSTR; { in case of bad input } X defn[1] := ENDSTR; X if (GetPBC(c) <> LPAREN) then X Message('define: missing left paren') X else if (not IsLetter(GetTok(token, tokSize))) then X Message('define: non-alphanumeric name') X else if (GetPBC(c) <> COMMA) then X Message('define: missing comma in define') X else begin { got '(name,' so far } X while (GetPBC(c) = BLANK) do X ; { skip leading blanks } X PutBack(c); { went one too far } X nlPar := 0; X i := 1; X while (nlPar >= 0) do begin X defn[i] := GetPBC(c); X if (i >= defSize) then X Error('define: definition too long') X else if (c = ENDFILE) then X Error('define: missing right paren') X else if (c = LPAREN) then X nlPar := nlPar + 1 X else if (c = RPAREN) then X nlPar := nlPar - 1; X { else normal char in defn[i] } X i := i + 1 X end; X defn[i-1] := ENDSTR X end Xend; / echo 'x - getfid.pascal' sed 's/^X//' > getfid.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{ GetFid -- convert a string into a file name } Xsegment GetFid; X%include swtools X%include ioref Xfunction GetFid; Xvar X nameIndex: 1..MAXSTR; X temp: StringType; X fMode: StringType; X fType: StringType; X i: 0..MAXSTR; X j: 0..MAXSTR; Xbegin X SCopy(line, idx, temp, 1); X for nameIndex := 1 to StrLength(temp) do X if (not (line[nameIndex] in X [DOLLAR, LETA..LETZ, BIGA..BIGZ, DIG0..DIG9, BLANK])) then X temp[nameIndex] := BLANK; X i := GetWord(temp, 1, fileName); X if i = 0 then begin X GetFid := false; X return; X end; X j := GetWord(temp, i, fType); X if j = 0 then begin X CvtSST('TEMP', fType); X CvtSST('*', fMode); X end X else begin X j := GetWord(temp, j, fMode); X if j = 0 then X CvtSST('*', fMode); X end; X i := StrLength(fileName); X fileName[i+1] := PERIOD; X SCopy(fType, 1, fileName, i + 2); X i := StrLength(fileName); X fileName[i+1] := PERIOD; X SCopy(fMode, 1, fileName, i + 2); X getFid := true; Xend; / echo 'x - getfn.pascal' sed 's/^X//' > getfn.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{ GetFn -- get file name from lin[i] .... } Xsegment GetFn; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref Xfunction GetFn; Xvar X k: Integer; X stat: STCode; Xbegin X stat := ERR; X if (lin[i+1] = BLANK) then begin X Scopy(lin, i+2, fil, 1); X if fil[StrLength(fil)] = NEWLINE then X fil[StrLength(fil)] := ENDSTR; X stat := OK X end X else if (lin[i+1] = NEWLINE) and (saveFile[1] <> ENDSTR) then begin X Scopy(saveFile, 1, fil, 1); X stat := OK X end; X if (stat = OK) and (saveFile[1] = ENDSTR) then X Scopy(fil, 1, saveFile, 1); { save if no old one } X k := 1; X if stat = Ok then X if (not GetFid(saveFile, k, saveFile)) then X stat := ERR; X GetFn := stat Xend; / echo 'x - getline.pascal' sed 's/^X//' > getline.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{ GetLine-- put string out on file } Xsegment GetLine; X%include swtools X%include ioref Xref termInput: Boolean; Xfunction GetKeyBoard(var str: StringType; maxSize: Integer): Boolean; X forward; Xfunction GetLine; Xvar X i: Integer; Xbegin X if (fd < STDIN) or (fd > MAXOPEN) or X (openList[fd].mode <> IOREAD) then X Error('Getline with unopen or bad fd') X else if (fd = STDIN) and (termInput) then X GetLine := GetKeyBoard(str, maxSize) X else begin X i := 1; X GetLine := false; X if Eof(openList[fd].fileVar) then begin X str[1] := NEWLINE; X str[2] := ENDSTR; X return; X end; X Readln(openList[fd].fileVar, str); X i := maxSize; X while (i > 0) do begin X if (str[i] <> BLANK) then leave; X i := i - 1 X end; X str[i+1] := NEWLINE; X str[i+2] := ENDSTR; X GetLine := true X end Xend; Xfunction GetKeyBoard; Xvar X i: Integer; Xbegin X ReadLn(openList[STDIN].fileVar, str); X if Eof(openList[STDIN].fileVar) then begin X TermIn(openList[STDIN].fileVar); X i := 0 X end X else begin X i := maxSize; X while (i > 0) do begin X if str[i] <> BLANK then leave; X i := i - 1 X end X end; X str[i + 1] := NEWLINE; X str[i + 2] := ENDSTR; X if (str[1] = ATSIGN) and (str[2] = NEWLINE) then X GetKeyBoard := false X else X GetKeyBoard := true Xend; / echo 'x - getlist.pascal' sed 's/^X//' > getlist.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{ GetList -- Get list of line numbers at lin[i], increment i } Xsegment GetList; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref Xfunction GetList; Xvar X num: Integer; X done: Boolean; Xbegin X line2 := 0; X nLines := 0; X done := (GetOne(lin, i, num, status) <> OK); X if done and (lin[i] = COMMA) then begin X done := false; X num := 1 X end; {if} X while (not done) do begin X line1 := line2; X line2 := num; X nLines := nLines + 1; X if (lin[i] = SEMICOL) then X curLn := num; X if (lin[i] = COMMA) or (lin[i] = SEMICOL) then begin X i := i + 1; X done := (GetOne(lin, i, num, status) <> OK); X if done then begin X num := lastLn; X done := false X end {if} X end X else X done := true X end; X nLines := Min(nLines, 2); X if (nLines = 0) then X line2 := curLn; X if (nLines <= 1) then X line1 := line2; X if (status <> ERR) then X status := OK; X GetList := status Xend; / echo 'x - getnum.pascal' sed 's/^X//' > getnum.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{ GetNum -- get single line number component } Xsegment GetNum; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref Xfunction GetNum; Xbegin X status := OK; X SkipBl(lin, i); X if (IsDigit(lin[i])) then begin X num := CToI(lin, i); X i := i - 1 { move back, to be advanced at end } X end X else if (lin[i] = PLUS) or (lin[i] = MINUS) then begin X num := curLn; X i := i - 1; {don't eat the plus or minus sign} X end X else if (lin[i] = CURLINE) then X num := curLn X else if (lin[i] = LASTLINE) then X num := lastLn X else if (lin[i] = SCAN) or (lin[i] = BACKSCAN) then begin X if (OptPat(lin,i) = ERR) then { build pattern } X status := ERR X else X status := PatScan(lin[i], num) X end X else X status := ENDDATA; X if (status = OK) then X i := i + 1; { advance to next character } X GetNum := status Xend; / echo 'x - getone.pascal' sed 's/^X//' > getone.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{ GetOne -- get one line number expression } Xsegment GetOne; X%include swtools X%include editcons X%include edittype X%include editref X%include editproc Xfunction GetOne; Xvar X iStart, mul, pNum: Integer; Xbegin X iStart := i; X num := 0; X if (GetNum(lin, i, num, status) = OK) then { 1st term } X repeat { + or - terms } X SkipBl(lin, i); X if (lin[i] <> PLUS) and (lin[i] <> MINUS) then X status := ENDDATA X else begin X if (lin[i] = PLUS) then X mul := 1 X else X mul := -1; X i := i + 1; X if (GetNum(lin, i, pNum, status) = OK) then X num := num + mul * pNum; X if (status = ENDDATA) then X status := ERR X end X until (status <> OK); X if (num < 0) or (num > lastLn) then X status := ERR; X if (status <> ERR) then begin X if (i <= iStart) then X status := ENDDATA X else X status := OK X end; X GetOne := status Xend; / echo 'x - getpat.pascal' sed 's/^X//' > getpat.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{ GetPat -- get pattern from lin, increment i } Xsegment GetPat; X%include swtools X%include patdef Xfunction GetPat; Xbegin X GetPat := (MakePat(arg, 1, ENDSTR, pat) > 0) Xend; / echo 'x - install.pascal' sed 's/^X//' > install.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{ Install -- add name, definition and type to table } Xsegment Install; X%include swtools X%include defdef X%include defref X%include defproc Xprocedure Install; Xvar X h, dlen, nlen: Integer; X p: NDPtr; Xbegin X nlen := StrLength(name) + 1; { 1 for ENDSTR } X dlen := StrLength(defn) + 1; X if (nextTab + nlen + dlen > MAXCHARS) then begin X PutStr(name, STDERR); X Error(': too many definitions') X end X else begin X h := Hash(name); X new(p); X p->.nextPtr := hashTab[h]; X hashTab[h] := p; X p->.name := nextTab; X SCCopy(name, ndTable, nextTab); X nextTab := nextTab + nlen; X p->.defn := nextTab; X SCCopy(defn, ndTable, nextTab); X nextTab := nextTab + dlen; X p->.kind := t X end Xend; / echo 'x - kopy.pascal' sed 's/^X//' > kopy.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{ Kopy -- move line1 thru line2 after line3 } Xsegment Kopy; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref Xfunction Kopy; Xvar X i: Integer; X curSave, lastSave: Integer; X tempLine: StringType; Xbegin X if (line1 <= 0) or ((line3 >= line1) and (line3 < line2)) then X Kopy := ERR X else begin X curSave := curLn; X lastSave := lastLn; X curLn := lastLn; X for i := line1 to line2 do begin X GetTxt(i, tempLine); X if PutTxt(tempLine) = ERR then begin X curLn := curSave; X lastLn := lastSave; X Kopy := ERR; X return X end X end; {if} X BlkMove(lastSave+1, lastSave+1+line2-line1, line3); X if (line3 > line1) then X curLn := line3 X else X curLn := line3 + (line2 - line1 + 1); X Kopy := OK X end Xend; / echo 'x - makesub.pascal' sed 's/^X//' > makesub.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{ MakeSub -- make substitution string from arg into sub } Xsegment MakeSub; X%include swtools X%include patdef X%include subdef X%include metadef Xvalue X nullMetaTable := MetaTableType( X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0), X MetaElementType(0,0)); Xfunction MakeSub; Xvar X k: Integer; X i, j: Integer; X l: Integer; X junk: Boolean; Xbegin X j := 1; X i := from; X k := from; X while (arg[k] <> delim) and (k <= (MAXSTR - 2)) 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 while (arg[i] <> delim) and (arg[i] <> ENDSTR) do begin X if (arg[i] = AMPER) then begin X junk := AddStr(DITTO, sub, j, MAXPAT); X { &n handler for meta brackets } X if (arg[i+1] in [DIG0..DIG9]) then begin X i := i + 1; X junk := AddStr(Chr(Ord(arg[i]) - Ord(DIG0)), X sub, j, MAXPAT) X end X end X else X junk := AddStr(Esc(arg,i), sub, j, MAXPAT); X i := i + 1 X end; X if (arg[i] <> delim) then { missing delim } X MakeSub := 0 X else if (not AddStr(ENDSTR, sub, j, MAXPAT)) then X MakeSub := 0 X else X MakeSub := i Xend; / echo 'x - mputstr.pascal' sed 's/^X//' > mputstr.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{ MPutStr -- put meta'd string out on file } Xsegment MPutStr; X%include swtools X%include ioref Xprocedure MPutStr; Xvar X i: Integer; X j: integer; X len: Integer; X outString: StringType; Xbegin X i := 1; X j := 1; X len := StrLength(str); X while i <= len do begin X if str[i] = DOLLAR then begin X i := i + 1; X if (str[i] = BIGN) or (str[i] = LETN) then begin X if j = 1 then WriteLn(openList[fd].fileVar,' ') X else WriteLn(openList[fd].fileVar, X outString:j-1); X j := 1 X end X else if (str[i] = BIGE) or (str[i] = LETE) then X return X else X i := i - 1 X end else X if str[i] = NEWLINE then begin X if j = 1 then WriteLn(openList[fd].fileVar,' ') X else WriteLn(openList[fd].fileVar, outString:j-1); X j := 1; X end {then} X else begin X outString[j] := str[i]; X j := j + 1; X end; {if} X i := i + 1 X end; {while} X if j <> 1 then write(openList[fd].fileVar, outString:j-1); Xend; {MPutStr} / echo 'x - omatch.pascal' sed 's/^X//' > omatch.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{ OMatch -- match one pattern element at pat[j] } Xsegment OMatch; X%include swtools X%include matchdef X%include patdef X%include metadef Xfunction OMatch; Xvar X advance: -1..1; X mIndex: Integer; Xbegin X advance := -1; X if (lin[i] = ENDSTR) then X OMatch := false X else X case pat[j] of X LITCHAR: X if (lin[i] = pat[j+1]) then X advance := 1; X BOM: X if (metaStackPointer <= 9) and X (metaIndex <= 9) then begin X metaStack[metaStackPointer] := metaIndex; X metaTable[metaIndex].first := i; X metaIndex := metaIndex + 1; X metaStackPointer := metaStackPointer + 1; X advance := 0 X end X else X Error('OMatch/meta: can''t happen'); X EOM: X if (metaStackPointer >= 1) then begin X metaStackPointer := metaStackPointer - 1; X mIndex := metaStack[metaStackPointer]; X metaTable[mIndex].last := i; X advance := 0 X end X else X Error('OMatch/meta/EOM can''t happen'); X BOL: X if (i = 1) then X advance := 0; X ANY: X if (lin[i] <> NEWLINE) then X advance := 1; X EOL: X if (lin[i] = NEWLINE) then X advance := 0; X CCL: X if (Locate(lin[i], pat, j+1)) then X advance := 1; X NCCL: X if (lin[i] <> NEWLINE) and X (not Locate(lin[i], pat, j+1)) then X advance := 1 X otherwise X Error('in omatch: can''t happen') X end; X if (advance >= 0) then begin X i := i + advance; X OMatch := true X end X else X OMatch := false Xend; / echo 'x - onerror.pascal' sed 's/^X//' > onerror.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{ OnError -- intercept pascalvs run-time errors } Xsegment OnError; Xdef ERRORIO: Boolean; Xdef ATTENTION: Boolean; Xdef OUTOFSPACE: Boolean; Xvalue X ERRORIO := false; X ATTENTION := false; X OUTOFSPACE := false; X%include onerror Xprocedure OnError; Xvar X statementNumber: String(10); X procName: String(10); X errorNo: String(10); Xbegin X if (FERROR in [41..53,75..78]) then begin X ERRORIO := true; X FACTION := []; X end X else if FERROR = 30 then begin X ATTENTION := true; X FACTION := []; X end X else if (FERROR = 64) and (not OUTOFSPACE) then begin X OUTOFSPACE := true; X FACTION := [] X end X else if FERROR = 36 then begin X FACTION := [XUMSG,XTRACE,XHALT]; X WriteStr(statementNumber, FSTMTNO:5); X WriteStr(procName, FPROCNAME:8); X WriteStr(errorNo, FERROR:5); X FRETMSG := 'SWTOOLS ASSERT FAILURE: RID=' || PROCNAME|| X '; S#=' || statementNumber || X '; EID' || errorNo || ';'; X end X else begin X FACTION := [XUMSG,XTRACE]; X WriteStr(statementNumber, FSTMTNO:5); X WriteStr(procName, FPROCNAME:8); X WriteStr(errorNo, FERROR: 5); X FRETMSG := '***SWTOOLS error: RID=' || procName X || '; S#=' || statementNumber || X '; EID=' || errorNo || ';'; X end Xend; / echo 'x - rot.pascal' sed 's/^X//' > rot.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{ Rot -- Rotate a file 90 degrees clockwise } Xprogram Rot; X%include swtools Xconst X maxWidth = 2000; X maxHeight = 130; Xvar X buffers: array [1..maxHeight] of array X [1..maxWidth] of Char; X i: Integer; X j: Integer; X maxReadWidth: Integer; X maxReadHeight: Integer; Xbegin X ToolInit; X i := 1; X j := 1; X maxReadWidth := 0; X while (GetC(buffers[i,j]) <> ENDFILE) do begin X if (buffers[i,j] = NEWLINE) then begin X maxReadWidth := Max(maxReadWidth,j); X for j := j to maxWidth do X buffers[i,j] := BLANK; X j := 1; X i := i + 1; X end X else X j := j + 1; X if (i > maxHeight) or (j > maxWidth) then begin X Message('input file too big'); X leave X end X end; X maxReadHeight := i - 1; X for i := 1 to maxReadWidth do begin X for j := maxReadHeight downto 1 do X PutC (buffers[j,i]); X PutC (NEWLINE) X end; Xend. / echo 'x - subst.pascal' sed 's/^X//' > subst.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{ SubSt -- substitute "sub" for occurrences of pattern } Xsegment SubSt; X%include swtools X%include editcons X%include edittype X%include editproc X%include editref X%include matchdef X%include subdef Xfunction SubSt; Xvar X new, old: StringType; X j, k, lastm, line, m: Integer; X stat: STCode; X done, subbed, junk: Boolean; Xbegin X if (glob) then X stat := OK X else X stat := ERR; X done := (line1 <= 0); X line := line1; X while (not done) and (line <= line2) do begin X j := 1; X subbed := false; X GetTxt(line, old); X lastm := 0; X k := 1; X while (old[k] <> ENDSTR) do begin X if (gFlag) or (not subbed) then X m := AMatch(old, k, pat, 1) X else X m := 0; X if (m > 0) and (lastm <> m) then begin X { replace matched text } X subbed := true; X CatSub(old, k, m, sub, new, j, MAXSTR); X lastm := m X end; X if (m = 0) or (m = k) then begin X { no match or null match } X junk := AddStr(old[k], new, j, MAXSTR); X k := k + 1 X end X else X { skip matched text } X k := m X end; X if (subbed) then begin X if (not AddStr(ENDSTR, new, j, MAXSTR)) then begin X stat := ERR; X done := true X end X else begin X stat := LnDelete(line, line, stat); X stat := PutTxt(new); X line2 := line2 + curLn - line; X line := curLn; X if (stat = ERR) then X done := true X else X stat := OK X end X end; X line := line + 1 X end; X SubSt := stat Xend; / echo 'x - sw.pascal' sed 's/^X//' > sw.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{ SW[edit] -- main routine for text editor } Xprogram SW; X%include swtools X%include editcons X%include edittype X%include editproc Xvar X curSave, i: Integer; X status: STCode; X more: Boolean; X argIndex: Integer; Xdef line1: Integer; { first line number } Xdef line2: Integer; { second line number } Xdef nLines: Integer; { # lines in buffer } Xdef curLn: Integer; { current line: value of dot } Xdef lastLn: Integer; { last line: value of $ } Xdef pat: StringType; { pattern } Xdef lin: StringType; { input line } Xdef saveFile: StringType; { file name } Xvalue X line1 := 0; X line2 := 0; X nLines := 0; Xbegin X ToolInit; X SetBuf; X pat[1] := ENDSTR; X saveFile[1] := ENDSTR; X i := 1; X for argIndex := 1 to Nargs do X if GetArg(argIndex, lin, MAXSTR) then begin X SCopy (lin, 1, saveFile, i); X i := StrLength(saveFile) + 2; X saveFile[i-1] := BLANK X end; X i := 1; X if saveFile[1] <> ENDSTR then X if (not GetFid(saveFile, i, saveFile)) then X saveFile[1] := ENDSTR; X if saveFile[1] <> ENDSTR then X if (DoRead(0, saveFile) = ERR) then X Message('Cannot open input file'); X if (OptIsOn(promptFlag)) then begin X PutC(COLON); X PutC(NEWLINE) X end; X more := GetLine(lin, STDIN, MAXSTR); X while (more) do begin X i := 1; X curSave := curLn; X if (GetList(lin, i, Status) = OK) then begin X if (CKGlob(lin, i, status) = OK) then X status := DoGlob(lin, i, curSave, status) X else if (status <> ERR) then X status := DoCmd(lin, i, false, status) X { else error - do nothing } X end; X if (status = ERR) then begin X Message('eh?'); X curLn := Min(curSave, lastLn) X end X else if (status = ENDDATA) then X more := false; X { else ok } X if (more) then begin X if OptIsOn(promptFlag) then begin X PutC(COLON); X PutC(NEWLINE) X end; X more := GetLine(lin, STDIN, MAXSTR) X end X end; X ClrBuf Xend. / echo 'x - swtr.pascal' sed 's/^X//' > swtr.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{ Translit -- map characters } Xprogram SWTr; X%include swtools X%include patdef Xvar X arg, fromSet, toSet: StringType; X c: CharType; X i, lastTo: 0..MAXSTR; X allBut, squash: Boolean; X{ XIndex -- conditionally invert value from strindex } Xfunction XIndex (var inSet: StringType; c: CharType; X allBut: Boolean; lastTo: Integer): Integer; Xbegin X if (c = ENDFILE) then X XIndex := 0 X else if (not allBut) then X XIndex := StrIndex(inSet,c) X else if (StrIndex(inSet,c) > 0) then X XIndex := 0 X else X XIndex := lastTo + 1 Xend; Xbegin X ToolInit; X if (not GetArg(1, arg, MAXSTR)) then X Error('usage: translit from to'); X allBut := (arg[1] = NEGATE); X if allBut then X i := 2 X else X i := 1; X if (not MakeSet(arg, i, fromSet, MaxStr)) then X Error('translit: "from" set too large'); X if (not GetArg(2,arg, MAXSTR)) then X toSet[1] := ENDSTR X else if (not MakeSet(arg, 1, toSet, MAXSTR)) then X Error('translit: "to" set too large') X else if (StrLength(fromSet) < StrLength(toSet)) then X Error('Translit: "from" shorter than "to"'); X lastTo := StrLength(toSet); X squash := (StrLength(fromSet) > lastTo) or (allBut); X repeat X i := XIndex(fromSet, GetC(c), allBut, lastTo); X if (squash) and (i >= lastTo) and (lastTo > 0) then begin X PutC(toSet[lastTo]); X repeat X i := XIndex(fromSet, GetC(c), allBut, lastTo) X until (i < lastTo) X end; X if (c <> ENDFILE) then begin X if (i > 0) and (lastTo > 0) then { translate } X PutC(toSet[i]) X else if (i = 0) then { copy } X PutC(c) X { else delete (don't print) } X end X until (c = ENDFILE) Xend; / echo 'x - unique.pascal' sed 's/^X//' > unique.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{ Unique -- strip adjacent duplicate lines in a file } Xprogram Unique; X%include swtools Xvar X buffer: array [0..1] of StringType; X bufNum: 0..1; X sameRecCount: Integer; X counts: Boolean; X lastRec: StringType; Xbegin X ToolInit; X buffer[1,1] := ENDSTR; X buffer[0,1] := NEWLINE; { just so's they're different } X lastRec := buffer[1]; X counts := NArgs > 0; X bufNum := 0; X sameRecCount := 0; X while(GetLine(buffer[bufNum], STDIN, MAXSTR)) do begin X if (not Equal(buffer[0], buffer[1])) then begin X if counts and (sameRecCount <> 0) then begin X PutDec(sameRecCount, 6); X PutC(BLANK) X end; X if sameRecCount <> 0 then X PutStr(lastRec, STDOUT); X lastRec := buffer[bufNum]; X sameRecCount := 1 X end X else X sameRecCount := sameRecCount + 1; X bufNum := (1 - bufNum) X end; X if sameRecCount <> 0 then begin X if counts then begin X PutDec(sameRecCount, 6); X PutC(BLANK) X end; X PutStr(lastRec, STDOUT) X end Xend. / echo 'x - unrotate.pascal' sed 's/^X//' > unrotate.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{ UnRotate -- Unrotate lines rotated by first half of KWIC } XProgram UnRotate; X%include swtools Xconst X MAXOUT = 80; X MIDDLE = 40; X FOLD = DOLLAR; Xvar X inBuf, outBuf: StringType; X tempFile2: FileDesc; X i, j, f: Integer; Xbegin X ToolInit; X tempFile2 := STDIN; 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; / echo 'Part 04 of pack.out complete.' exit