-h- README 1647 Software Tools in Pascal Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. This tape or disk contains all of the programs from Software Tools in Pascal, plus the documentation. There are 361 files (8500 lines; 210000 characters). The format of the tape is 800 bpi 9 track ASCII in 512 byte blocks. Each source line is terminated by an ASCII newline character; each file is introduced by a line of the form -h- directory/filename number-of-bytes as in the archive program of Chapter 3. The "number-of-bytes" field includes the copyright notice and the terminating newline. The "directory" is intended to help you assign the files to the proper programs. Directories are: UCBPRIMS primitives for UCB Pascal WSPRIMS primitives for Whitesmiths Pascal UCSDPRIMS primitives for UCSD Pascal UTIL utility routines common to all programs INTRO programs from Chapter 1 FILTERS all programs from Chapter 2 except translit TRANSLIT translit program from Chapter 2 FILEIO early programs in Chapter 3 PRINT print programs from Chapter 3 ARCHIVE archive program from Chapter 3 SORT all programs from Chapter 4; mostly sorting EDIT all programs from Chapters 5 and 6: find, change, edit FORMAT format program from Chapter 7 MACRO define and macro processors from Chapter 8 MAN manual pages for programs PMAN manual pages for primitives Within each group, files are presented in alphabetical order. Each file begins with a header like this one: -h- UCBPRIMS/getc.p 341 which indicates that getc.p is part of the UCB primitives and is 341 bytes long. The list of file names and sizes from the tape follows. UCBPRIMS/close.p 315 UCBPRIMS/create.p 890 UCBPRIMS/getarg.p 642 UCBPRIMS/getc.p 341 UCBPRIMS/getcf.p 484 UCBPRIMS/getline.p 453 UCBPRIMS/initio.p 427 UCBPRIMS/nargs.p 219 UCBPRIMS/open.p 911 UCBPRIMS/prims.p 379 UCBPRIMS/putc.p 223 UCBPRIMS/putcf.p 319 UCBPRIMS/putstr.p 271 UCBPRIMS/remove.p 360 WSPRIMS/Base.p 2558 WSPRIMS/addstr.p 353 WSPRIMS/ctoi.p 502 WSPRIMS/equal.p 303 WSPRIMS/esc.p 497 WSPRIMS/fcopy.p 372 WSPRIMS/getc.p 466 WSPRIMS/getline.p 597 WSPRIMS/index.p 317 WSPRIMS/istuff.p 867 WSPRIMS/itoc.p 454 WSPRIMS/length.p 251 WSPRIMS/maxmin.p 353 WSPRIMS/pcreate.p 379 WSPRIMS/popen.p 367 WSPRIMS/pputstr.p 368 WSPRIMS/prims.p 2558 WSPRIMS/putc.p 349 WSPRIMS/putdec.p 432 WSPRIMS/scopy.p 320 WSPRIMS/seek.p 325 WSPRIMS/tools.p 1726 UCSDPRIMS/Call.p 108 UCSDPRIMS/chars.p 1292 UCSDPRIMS/close.p 393 UCSDPRIMS/create.p 550 UCSDPRIMS/endcmd.p 210 UCSDPRIMS/fcopy.p 237 UCSDPRIMS/fdalloc.p 553 UCSDPRIMS/fgetcf.p 350 UCSDPRIMS/fputcf.p 236 UCSDPRIMS/ftalloc.p 360 UCSDPRIMS/getarg.p 343 UCSDPRIMS/getc.p 212 UCSDPRIMS/getcf.p 378 UCSDPRIMS/getkbd.p 1083 UCSDPRIMS/getline.p 660 UCSDPRIMS/initcmd.p 1389 UCSDPRIMS/mustcreate.p 347 UCSDPRIMS/mustopen.p 335 UCSDPRIMS/nargs.p 174 UCSDPRIMS/open.p 557 UCSDPRIMS/prims.p 1899 UCSDPRIMS/putc.p 189 UCSDPRIMS/putcf.p 343 UCSDPRIMS/putdec.p 304 UCSDPRIMS/putstr.p 277 UCSDPRIMS/remove.p 445 UCSDPRIMS/strname.p 333 UTIL/addstr.p 347 UTIL/ctoi.p 502 UTIL/equal.p 303 UTIL/esc.p 462 UTIL/fcopy.p 237 UTIL/globdefs.p 2030 UTIL/index.p 336 UTIL/isalphanum.p 266 UTIL/isdigit.p 201 UTIL/isletter.p 245 UTIL/islower.p 211 UTIL/isupper.p 211 UTIL/itoc.p 438 UTIL/itoctest.p 312 UTIL/length.p 251 UTIL/max.p 212 UTIL/min.p 212 UTIL/mustcreate.p 347 UTIL/mustopen.p 335 UTIL/putdec.p 303 UTIL/scopy.p 320 UTIL/utility.p 507 INTRO/charcount.p 279 INTRO/copy.p 193 INTRO/detab.p 648 INTRO/linecount.p 299 INTRO/settabs.p 288 INTRO/tabpos.p 273 INTRO/wholecopy.p 839 INTRO/wordcount.p 442 FILTERS/compress.p 597 FILTERS/echo.p 381 FILTERS/entab.p 802 FILTERS/expand.p 558 FILTERS/overstrike.p 788 FILTERS/putrep.p 425 FILTERS/settabs.p 288 FILTERS/tabpos.p 273 TRANSLIT/dodash.p 891 TRANSLIT/makeset.p 373 TRANSLIT/translit.p 1292 TRANSLIT/xindex.p 410 FILEIO/compare.p 872 FILEIO/compare0.p 651 FILEIO/concat.p 347 FILEIO/dcompare.p 424 FILEIO/diffmsg.p 289 FILEIO/finclude.p 594 FILEIO/getword.p 478 FILEIO/include.p 483 FILEIO/makecopy.p 432 PRINT/fprint.p 806 PRINT/head.p 486 PRINT/print.p 517 PRINT/print0.p 364 PRINT/skip.p 200 ARCHIVE/acopy.p 338 ARCHIVE/addfile.p 489 ARCHIVE/archive.p 1011 ARCHIVE/archproc.p 442 ARCHIVE/delete.p 549 ARCHIVE/extract.p 799 ARCHIVE/filearg.p 480 ARCHIVE/fmove.p 304 ARCHIVE/fsize.p 333 ARCHIVE/fskip.p 302 ARCHIVE/getfns.p 595 ARCHIVE/gethdr.p 504 ARCHIVE/getword.p 478 ARCHIVE/help.p 195 ARCHIVE/initarch.p 509 ARCHIVE/makehdr.p 437 ARCHIVE/notfound.p 318 ARCHIVE/replace.p 487 ARCHIVE/table.p 406 ARCHIVE/tprint.p 392 ARCHIVE/update.p 679 SORT/bubble.p 371 SORT/cmp.p 551 SORT/cscopy.p 318 SORT/exchange.p 245 SORT/gname.p 408 SORT/gopen.p 320 SORT/gremove.p 323 SORT/gtext.p 736 SORT/inmemquick.p 684 SORT/inmemsort.p 675 SORT/kwic.p 257 SORT/makefile.p 246 SORT/merge.p 993 SORT/ptext.p 397 SORT/putrot.p 439 SORT/quick.p 234 SORT/reheap.p 594 SORT/rotate.p 354 SORT/rquick.p 754 SORT/sccopy.p 318 SORT/shell.p 621 SORT/shell0.p 572 SORT/sort.p 1284 SORT/sortproc.p 304 SORT/sortquick.p 690 SORT/sorttest.p 424 SORT/unique.p 380 SORT/unrotate.p 783 EDIT/altpatsize.p 472 EDIT/amatch.p 1265 EDIT/amatch0.p 367 EDIT/amatch1.p 392 EDIT/append.p 599 EDIT/blkmove.p 366 EDIT/catsub.p 510 EDIT/change.p 630 EDIT/chngcons.p 194 EDIT/chngproc.p 190 EDIT/ckglob.p 827 EDIT/ckp.p 411 EDIT/clrbuf1.p 170 EDIT/clrbuf2.p 203 EDIT/default.p 363 EDIT/docmd.p 2981 EDIT/dodash.p 891 EDIT/doglob.p 664 EDIT/doprint.p 369 EDIT/doread.p 645 EDIT/dowrite.p 473 EDIT/edit.p 994 EDIT/editcons.p 695 EDIT/editproc.p 676 EDIT/edittype.p 93 EDIT/editvar.p 92 EDIT/edprim.p 93 EDIT/edprim1.p 240 EDIT/edprim2.p 258 EDIT/edtype1.p 307 EDIT/edtype2.p 260 EDIT/edvar1.p 485 EDIT/edvar2.p 722 EDIT/find.p 454 EDIT/findcons.p 378 EDIT/getccl.p 636 EDIT/getfn.p 668 EDIT/getlist.p 793 EDIT/getmark.p 187 EDIT/getnum.p 755 EDIT/getone.p 891 EDIT/getpat.p 245 EDIT/getrhs.p 544 EDIT/getsub.p 248 EDIT/gettxt1.p 213 EDIT/gettxt2.p 345 EDIT/getword.p 478 EDIT/lndelete.p 371 EDIT/locate.p 502 EDIT/makepat.p 1385 EDIT/makesub.p 657 EDIT/match.p 358 EDIT/move.p 401 EDIT/nextln.p 217 EDIT/omatch.p 977 EDIT/optpat.p 579 EDIT/patscan.p 487 EDIT/patsize.p 483 EDIT/prevln.p 217 EDIT/putmark.p 184 EDIT/putsub.p 393 EDIT/puttxt1.p 398 EDIT/puttxt2.p 440 EDIT/reverse.p 305 EDIT/seek.p 520 EDIT/setbuf1.p 272 EDIT/setbuf2.p 521 EDIT/skipbl.p 236 EDIT/stclose.p 427 EDIT/subline.p 622 EDIT/subst.p 1358 FORMAT/break.p 275 FORMAT/center.p 214 FORMAT/command.p 1173 FORMAT/fmtcons.p 196 FORMAT/fmtproc.p 571 FORMAT/format.p 1820 FORMAT/format0.p 1820 FORMAT/getcmd.p 889 FORMAT/gettl.p 423 FORMAT/getval.p 462 FORMAT/getword.p 478 FORMAT/initfmt.p 574 FORMAT/leadbl.p 402 FORMAT/page.p 247 FORMAT/put.p 447 FORMAT/putfoot.p 225 FORMAT/puthead.p 301 FORMAT/puttl.p 317 FORMAT/putword.p 809 FORMAT/putword0.p 633 FORMAT/setparam.p 518 FORMAT/skip.p 202 FORMAT/skipbl.p 236 FORMAT/space.p 343 FORMAT/spread.p 816 FORMAT/text.p 762 FORMAT/text0.p 183 FORMAT/text1.p 567 FORMAT/underln.p 553 FORMAT/width.p 377 MACRO/cscopy.p 318 MACRO/defcons.p 339 MACRO/define.p 836 MACRO/defproc.p 379 MACRO/deftype.p 417 MACRO/defvar.p 346 MACRO/dochq.p 473 MACRO/dodef.p 350 MACRO/doexpr.p 296 MACRO/doif.p 507 MACRO/dolen.p 305 MACRO/dosub.p 734 MACRO/eval.p 1083 MACRO/expr.p 462 MACRO/factor.p 413 MACRO/getdef.p 1122 MACRO/getpbc.p 323 MACRO/gettok.p 591 MACRO/gnbchar.p 266 MACRO/hash.p 287 MACRO/hashfind.p 447 MACRO/initdef.p 412 MACRO/inithash.p 261 MACRO/initmacro.p 1446 MACRO/install.p 727 MACRO/lookup.p 369 MACRO/maccons.p 494 MACRO/macproc.p 581 MACRO/macro.p 2396 MACRO/mactype.p 468 MACRO/macvar.p 1107 MACRO/pbnum.p 249 MACRO/pbstr.p 224 MACRO/push.p 319 MACRO/putback.p 263 MACRO/putchr.p 332 MACRO/puttok.p 266 MACRO/sccopy.p 318 MACRO/term.p 514 MAN/archive.m 1987 MAN/change.m 840 MAN/charcount.m 471 MAN/close.m 339 MAN/compare.m 568 MAN/compress.m 839 MAN/concat.m 436 MAN/copy.m 565 MAN/create.m 650 MAN/define.m 879 MAN/detab.m 638 MAN/echo.m 385 MAN/edit.m 4040 MAN/entab.m 802 MAN/error.m 362 MAN/expand.m 737 MAN/find.m 1802 MAN/format.m 2268 MAN/getarg.m 572 MAN/getc.m 618 MAN/getline.m 704 MAN/include.m 587 MAN/kwic.m 704 MAN/linecount.m 290 MAN/macro.m 2869 MAN/makecopy.m 515 MAN/open.m 484 MAN/overstrike.m 897 MAN/print.m 729 MAN/putc.m 601 MAN/putstr.m 470 MAN/remove.m 298 MAN/seek.m 450 MAN/sort.m 683 MAN/translit.m 1669 MAN/unique.m 484 MAN/unrotate.m 1035 MAN/wordcount.m 423 PMAN/close.m 280 PMAN/create.m 943 PMAN/error.m 364 PMAN/getarg.m 557 PMAN/getc.m 722 PMAN/getcf.m 776 PMAN/getline.m 701 PMAN/message.m 311 PMAN/nargs.m 411 PMAN/open.m 972 PMAN/putc.m 350 PMAN/putcf.m 360 PMAN/putstr.m 431 PMAN/remove.m 493 PMAN/seek.m 651 -h- UCBPRIMS/close.p 315 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { close (UCB) -- release file descriptor slot for open file } procedure close (fd : filedesc); begin if (fd > STDERR) and (fd <= MAXOPEN) then begin flush(openlist[fd].filevar); { in case buffered } openlist[fd].mode := IOAVAIL end end; -h- UCBPRIMS/create.p 890 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { create (UCB) -- create a file } { non-portable -- uses the Berkeley interface to Unix } { no status can be returned, unfortunately } function create (var name : string; mode : integer) : filedesc; var i : integer; intname : array [1..MAXSTR] of char; found : boolean; begin i := 1; while (name[i] <> ENDSTR) do begin intname[i] := chr(name[i]); i := i + 1 end; for i := i to MAXSTR do intname[i] := ' '; { pad name with blanks } { find a free slot in openlist } create := IOERROR; found := false; i := 1; while (i <= MAXOPEN) and (not found) do begin if (openlist[i].mode = IOAVAIL) then begin openlist[i].mode := mode; rewrite(openlist[i].filevar, intname); if (mode = IOREAD) then reset(openlist[i].filevar, intname); create := i; found := true end; i := i + 1 end end; -h- UCBPRIMS/getarg.p 642 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getarg (UCB) -- copy n-th command line argument into s } { uses the Berkeley function argv(i,s), } { which returns the 0th to argc-1th argument in s. } function getarg (n : integer; var s : string; maxs : integer) : boolean; var arg : array [1..MAXSTR] of char; i, lnb : integer; begin lnb := 0; if (n >= 0) and (n < argc) then begin { in the list } argv(n, arg); { get the argument } for i := 1 to MAXSTR-1 do begin s[i] := ord(arg[i]); if arg[i] <> ' ' then lnb := i end; getarg := true end else getarg := false; s[lnb+1] := ENDSTR end; -h- UCBPRIMS/getc.p 341 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getc (UCB) -- get one character from standard input } function getc (var c : character) : character; var ch : char; begin if eof then c := ENDFILE else if eoln then begin readln; c := NEWLINE end else begin read(ch); c := ord(ch) end; getc := c end; -h- UCBPRIMS/getcf.p 484 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getcf (UCB) -- get one character from file } function getcf (var c: character; fd : filedesc) : character; var ch : char; begin if (fd = STDIN) then getcf := getc(c) else if eof(openlist[fd].filevar) then c := ENDFILE else if eoln(openlist[fd].filevar) then begin read(openlist[fd].filevar, ch); c := NEWLINE end else begin read(openlist[fd].filevar, ch); c := ord(ch) end; getcf := c end; -h- UCBPRIMS/getline.p 453 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getline (UCB) -- get a line from file } function getline (var s : string; fd : filedesc; maxsize : integer) : boolean; var i : integer; c : character; begin i := 1; repeat s[i] := getcf(c, fd); i := i + 1 until (c = ENDFILE) or (c = NEWLINE) or (i >= maxsize); if (c = ENDFILE) then { went one too far } i := i - 1; s[i] := ENDSTR; getline := (c <> ENDFILE) end; -h- UCBPRIMS/initio.p 427 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { initio (UCB) -- initialize open file list } procedure initio; var i : filedesc; begin openlist[STDIN].mode := IOREAD; openlist[STDOUT].mode := IOWRITE; openlist[STDERR].mode := IOWRITE; { connect STDERR to user's terminal ... } rewrite(openlist[STDERR].filevar, '/dev/tty '); for i := STDERR+1 to MAXOPEN do openlist[i].mode := IOAVAIL; end; -h- UCBPRIMS/nargs.p 219 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { nargs (UCB) -- return number of arguments } { non-portable. uses Berkeley conventions } function nargs : integer; begin nargs := argc - 1 end; -h- UCBPRIMS/open.p 911 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { open (UCB) -- open a file for reading or writing } { non-portable -- uses the Berkeley interface to Unix } { no status can be returned, unfortunately } function open (var name : string; mode : integer) : filedesc; var i : integer; intname : array [1..MAXSTR] of char; found : boolean; begin i := 1; while (name[i] <> ENDSTR) do begin intname[i] := chr(name[i]); i := i + 1 end; for i := i to MAXSTR do intname[i] := ' '; { pad name with blanks } { find a free slot in openlist } open := IOERROR; found := false; i := 1; while (i <= MAXOPEN) and (not found) do begin if (openlist[i].mode = IOAVAIL) then begin openlist[i].mode := mode; if (mode = IOREAD) then reset(openlist[i].filevar, intname) else rewrite(openlist[i].filevar, intname); open := i; found := true end; i := i + 1 end end; -h- UCBPRIMS/prims.p 379 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { prims -- primitive functions and procedures for UCB } #include "initio.p" #include "open.p" #include "create.p" #include "getc.p" #include "getcf.p" #include "getline.p" #include "putc.p" #include "putcf.p" #include "putstr.p" #include "close.p" #include "remove.p" #include "getarg.p" #include "nargs.p" -h- UCBPRIMS/putc.p 223 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putc (UCB) -- put one character on standard output } procedure putc (c : character); begin if c = NEWLINE then writeln else write(chr(c)) end; -h- UCBPRIMS/putcf.p 319 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putcf (UCB) -- put a single character on file fd } procedure putcf (c : character; fd : filedesc); begin if (fd = STDOUT) then putc(c) else if c = NEWLINE then writeln(openlist[fd].filevar) else write(openlist[fd].filevar, chr(c)) end; -h- UCBPRIMS/putstr.p 271 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putstr (UCB) -- put out string on file } procedure putstr (var s : string; f : filedesc); var i : integer; begin i := 1; while (s[i] <> ENDSTR) do begin putcf(s[i], f); i := i + 1 end end; -h- UCBPRIMS/remove.p 360 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { remove (UCB) -- remove file s from file system } { this version just prints a message } procedure remove (var s : string); begin message('If we had remove, we would be removing '); putcf(TAB, STDERR); putstr(s, STDERR); putcf(NEWLINE, STDERR); flush(openlist[STDERR].filevar) end; -h- WSPRIMS/Base.p 2558 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { prims -- external declarations for Whitesmiths primitives } program xxx (input, output, errout); #include { Environment supplied primitives ... } procedure close (fd : filedesc); external; procedure exit (status : boolean); external; function getarg (n : integer; var str : string; maxsize : integer) : boolean; external; function nargs : integer; external; procedure remove (name : string); external; { Externally supplied primitive interfaces ... } function getc (var c : character) : character; external; function getcf (var c : character; fd : filedesc) : character; external; function getline (var str : string; fd : filedesc) : boolean; external; function pcreate (var name : string; mode : integer) : filedesc; external; function popen (var name : string; mode : integer) : filedesc; external; procedure pputstr (var str : string; fd : filedesc); external; procedure putc (c : character); external; procedure putcf (c : character; fd : filedesc); external; { Externally supplied utilities ... } function addstr (c : character; var outset : string; var j : integer; maxset : integer) : boolean; external; function ctoi (var s : string; var i : integer) : integer; external; function equal (var str1, str2 : string) : boolean; external; function esc (var s : string; var i : integer) : character; external; procedure fcopy (fin, fout : filedesc); external; function index (var s : string; c : character) : integer; external; function isalphanum (c : character) : boolean; external; function isletter (c : character) : boolean; external; function islower (c : character) : boolean; external; function isupper (c : character) : boolean; external; function itoc (n : integer; var str : string; i : integer) : integer; external; function length (var s : string) : integer; external; function max (x, y : integer) : integer; external; function min (x, y : integer) : integer; external; procedure putdec (n, w : integer); external; procedure scopy (var src : string; i : integer; var dest : string; j : integer); external; { Internally supplied primitives ... } function create (var name : string; mode : integer) : filedesc; begin create := pcreate(name, mode) end; function open (var name : string; mode : integer) : filedesc; begin open := popen(name, mode) end; procedure putstr (var str : string; fd : filedesc); begin pputstr(str, fd) end; #include #include { The body in question ... } -h- WSPRIMS/addstr.p 353 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { addstr -- put c in outset[j] if it fits, increment j } function addstr(c : character; var outset : string; var j : integer; maxset : integer) : boolean; begin if (j > maxset) then addstr := false else begin outset[j] := c; j := j + 1; addstr := true end end; -h- WSPRIMS/ctoi.p 502 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { ctoi -- convert string at s[i] to integer, increment i } function ctoi (var s : string; var i : integer) : integer; var n, sign : integer; begin while (s[i] = BLANK) or (s[i] = TAB) do i := i + 1; if (s[i] = MINUS) then sign := -1 else sign := 1; if (s[i] = PLUS) or (s[i] = MINUS) then i := i + 1; n := 0; while (isdigit(s[i])) do begin n := 10 * n + s[i] - ord('0'); i := i + 1 end; ctoi := sign * n end; -h- WSPRIMS/equal.p 303 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { equal -- test two strings for equality } function equal (var str1, str2 : string) : boolean; var i : integer; begin i := 1; while (str1[i] = str2[i]) and (str1[i] <> ENDSTR) do i := i + 1; equal := (str1[i] = str2[i]) end; -h- WSPRIMS/esc.p 497 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { esc -- map inset[i] into escaped character if appropriate } function esc (var inset : string; var i : integer) : character; begin if (inset[i] <> ESCAPE) then esc := inset[i] else if (inset[i+1] = ENDSTR) then { @ not special at end } esc := ESCAPE else begin i := i + 1; if (inset[i] = ord('n')) then esc := NEWLINE else if (inset[i] = ord('t')) then esc := TAB else esc := inset[i] end end; -h- WSPRIMS/fcopy.p 372 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fcopy -- copy file fin to file fout } function getcf (var c : character; fd : filedesc) : character; external; procedure putcf (c : character; fd : filedesc); external; procedure fcopy (fin, fout : filedesc); var c : character; begin while (getcf(c, fin) <> ENDFILE) do putcf(c, fout) end; -h- WSPRIMS/getc.p 466 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getc and getcf (WS) -- get one character of input } function read (fd : filedesc; var c : character; size : integer) : boolean; external; function getc (var c : character) : character; begin if (not read(STDIN, c, 1)) then c := ENDFILE; getc := c end; function getcf(var c : character; fd : filedesc) : character; begin if (not read(fd, c, 1)) then c := ENDFILE; getcf := c end; -h- WSPRIMS/getline.p 597 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getline (WS) -- get a line from file } function read (fd : filedesc; var c : character; size : integer) : boolean; external; function getline (var s : string; fd : filedesc; maxsize : integer) : boolean; var i : integer; c : character; done : boolean; begin i := 1; done := false; repeat if (read(fd, c, 1)) then s[i] := c else done := true; i := i + 1 until (done) or (c = NEWLINE) or (i >= maxsize); if (done) then { went one too far } i := i - 1; s[i] := ENDSTR; getline := (not done) end; -h- WSPRIMS/index.p 317 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { index -- find c in string s } function index (var s : string; c : character) : integer; var i : integer; begin i := 1; while (s[i] <> c) and (s[i] <> ENDSTR) do i := i + 1; if (s[i] = ENDSTR) then index := 0 else index := i end; -h- WSPRIMS/istuff.p 867 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { miscellaneous functions for things like islower isupper isletter isalphanum All of these work on 'character' data type and return boolean. } { islower(n) -- true if n is lower case } function islower (n : character) : boolean; begin islower := (ord('a') <= n) and (n <= ord('z')); end; { isupper(n) -- true if n is upper case } function isupper (n : character) : boolean; begin isupper := (ord('A') <= n) and (n <= ord('Z')); end; { isletter(n) -- true if n is a letter of either case } function isletter (n : character) : boolean; begin isletter := (ord('a') <= n) and (n <= ord('z')) or (ord('A') <= n) and (n <= ord('Z')); end; { isalphanum -- true if letter or digit } function isalphanum (n : character) : boolean; begin isalphanum := isletter(n) or isdigit(n); end; -h- WSPRIMS/itoc.p 454 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { itoc - convert integer n to char string in str[i]... } function itoc (n : integer; var str : string; i : integer) : integer; { returns 1st free i } begin if (n < 0) then begin str[i] := ord('-'); itoc := itoc(-n, str, i+1) end else begin if (n >= 10) then i := itoc(n div 10, str, i); str[i] := n mod 10 + ord('0'); str[i+1] := ENDSTR; itoc := i + 1 end end; -h- WSPRIMS/length.p 251 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { length -- compute length of string } function length (var s : string) : integer; var n : integer; begin n := 1; while (s[n] <> ENDSTR) do n := n + 1; length := n - 1 end; -h- WSPRIMS/maxmin.p 353 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { max -- compute maximum of two integers } function max (x, y : integer) : integer; begin if (x > y) then max := x else max := y end; { min -- compute minimum of two integers } function min (x, y : integer) : integer; begin if (x < y) then min := x else min := y end; -h- WSPRIMS/pcreate.p 379 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { pcreate (WS) -- Pascal create primitive } function create (var name : string; mode, rsize : integer) : filedesc; external; function pcreate (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := create(name, mode, 0); if (fd < 0) then fd := IOERROR; pcreate := fd end; -h- WSPRIMS/popen.p 367 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { popen (WS) -- Pascal open primitive } function open (var name : string; mode, rsize : integer) : filedesc; external; function popen (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := open(name, mode, 0); if (fd < 0) then fd := IOERROR; popen := fd end; -h- WSPRIMS/pputstr.p 368 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { pputstr (WS) -- Pascal putstr primitive } procedure write (fd : filedesc; var c : string; size : integer); external; procedure pputstr (var str : string; fd : filedesc); var i : integer; begin i := 1; while (str[i] <> ENDSTR) do i := i + 1; if (i > 1) then write(fd, str, i-1) end; -h- WSPRIMS/prims.p 2558 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { prims -- external declarations for Whitesmiths primitives } program xxx (input, output, errout); #include { Environment supplied primitives ... } procedure close (fd : filedesc); external; procedure exit (status : boolean); external; function getarg (n : integer; var str : string; maxsize : integer) : boolean; external; function nargs : integer; external; procedure remove (name : string); external; { Externally supplied primitive interfaces ... } function getc (var c : character) : character; external; function getcf (var c : character; fd : filedesc) : character; external; function getline (var str : string; fd : filedesc) : boolean; external; function pcreate (var name : string; mode : integer) : filedesc; external; function popen (var name : string; mode : integer) : filedesc; external; procedure pputstr (var str : string; fd : filedesc); external; procedure putc (c : character); external; procedure putcf (c : character; fd : filedesc); external; { Externally supplied utilities ... } function addstr (c : character; var outset : string; var j : integer; maxset : integer) : boolean; external; function ctoi (var s : string; var i : integer) : integer; external; function equal (var str1, str2 : string) : boolean; external; function esc (var s : string; var i : integer) : character; external; procedure fcopy (fin, fout : filedesc); external; function index (var s : string; c : character) : integer; external; function isalphanum (c : character) : boolean; external; function isletter (c : character) : boolean; external; function islower (c : character) : boolean; external; function isupper (c : character) : boolean; external; function itoc (n : integer; var str : string; i : integer) : integer; external; function length (var s : string) : integer; external; function max (x, y : integer) : integer; external; function min (x, y : integer) : integer; external; procedure putdec (n, w : integer); external; procedure scopy (var src : string; i : integer; var dest : string; j : integer); external; { Internally supplied primitives ... } function create (var name : string; mode : integer) : filedesc; begin create := pcreate(name, mode) end; function open (var name : string; mode : integer) : filedesc; begin open := popen(name, mode) end; procedure putstr (var str : string; fd : filedesc); begin pputstr(str, fd) end; #include #include { The body in question ... } -h- WSPRIMS/putc.p 349 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putc and putcf (WS) -- put one character of output } procedure write (fd : filedesc; var c : character; size : integer); external; procedure putc (c : character); begin write(STDOUT, c, 1) end; procedure putcf(c : character; fd : filedesc); begin write(fd, c, 1) end; -h- WSPRIMS/putdec.p 432 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putdec -- put decimal integer n in field width >= w } function itoc (n : integer; var str : string; i : integer) : integer; external; procedure putc (c : character); external; procedure putdec (n, w : integer); var i, nd : integer; s : string; begin nd := itoc(n, s, 1); for i := nd to w do putc(BLANK); for i := 1 to nd-1 do putc(s[i]); end; -h- WSPRIMS/scopy.p 320 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { scopy -- copy string at src[i] to dest[j] } procedure scopy (var src : string; i : integer; var dest : string; j : integer); begin while (src[i] <> ENDSTR) do begin dest[j] := src[i]; i := i + 1; j := j + 1 end; dest[j] := ENDSTR end; -h- WSPRIMS/seek.p 325 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { seek (WS) -- special version of primitive for edit } procedure lseek (fd : filedesc; off, hioff, mode : integer); external; { PDP-11 long format only } procedure seek (recno : integer; fd : filedesc); begin lseek(scrout, 0, MAXSTR * recno, 0) end; -h- WSPRIMS/tools.p 1726 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { tools.h -- definitions and types for WS primitives } #define ENDFILE -1 /* character constants */ #define ENDSTR 0 #define BACKSPACE 8 #define TAB 9 #define NEWLINE 10 #define BLANK 32 #define EXCLAM 33 #define DQUOTE 34 #define SHARP 35 #define DOLLAR 36 #define PERCENT 37 #define AMPER 38 #define SQUOTE 39 #define ACUTE SQUOTE #define LPAREN 40 #define RPAREN 41 #define STAR 42 #define PLUS 43 #define COMMA 44 #define MINUS 45 #define DASH MINUS #define PERIOD 46 #define SLASH 47 #define COLON 58 #define SEMICOL 59 #define LESS 60 #define EQUALS 61 #define GREATER 62 #define QUESTION 63 #define ATSIGN 64 #define ESCAPE ATSIGN #define LBRACK 91 #define BACKSLASH 92 #define RBRACK 93 #define CARET 94 #define UNDERLINE 95 #define GRAVE 96 #define LETA 97 #define LETB 98 #define LETC 99 #define LETD 100 #define LETE 101 #define LETF 102 #define LETG 103 #define LETH 104 #define LETI 105 #define LETJ 106 #define LETK 107 #define LETL 108 #define LETM 109 #define LETN 110 #define LETO 111 #define LETP 112 #define LETQ 113 #define LETR 114 #define LETS 115 #define LETT 116 #define LETU 117 #define LETV 118 #define LETW 119 #define LETX 120 #define LETY 121 #define LETZ 122 #define LBRACE 123 #define BAR 124 #define RBRACE 125 #define TILDE 126 #define IOERROR -1 #define STDIN 0 #define STDOUT 1 #define STDERR 2 #define MAXOPEN 8 #define IOREAD 0 #define IOWRITE 1 #define MAXSTR 100 type character = -128..127; filedesc = integer; string = array [1..MAXSTR] of character; #define message(str) writeln(errout, str) #define error(str) begin message(str); exit(false) end #define isdigit(c) ((ord('0') <= c) and (c <= ord('9'))) -h- UCSDPRIMS/Call.p 108 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } begin initcmd; PROG; endcmd end. -h- UCSDPRIMS/chars.p 1292 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { standard definitions of characters } #define ENDFILE -1 #define ENDSTR 0 #define BACKSPACE 8 #define TAB 9 #define NEWLINE 10 #define BLANK 32 #define EXCLAM 33 #define DQUOTE 34 #define SHARP 35 #define DOLLAR 36 #define PERCENT 37 #define AMPER 38 #define SQUOTE 39 #define ACUTE SQUOTE #define LPAREN 40 #define RPAREN 41 #define STAR 42 #define PLUS 43 #define COMMA 44 #define MINUS 45 #define DASH MINUS #define PERIOD 46 #define SLASH 47 #define COLON 58 #define SEMICOL 59 #define LESS 60 #define EQUALS 61 #define GREATER 62 #define QUESTION 63 #define ATSIGN 64 #define ESCAPE ATSIGN #define LBRACK 91 #define BACKSLASH 92 #define RBRACK 93 #define CARET 94 #define UNDERLINE 95 #define GRAVE 96 #define LETA 97 #define LETB 98 #define LETC 99 #define LETD 100 #define LETE 101 #define LETF 102 #define LETG 103 #define LETH 104 #define LETI 105 #define LETJ 106 #define LETK 107 #define LETL 108 #define LETM 109 #define LETN 110 #define LETO 111 #define LETP 112 #define LETQ 113 #define LETR 114 #define LETS 115 #define LETT 116 #define LETU 117 #define LETV 118 #define LETW 119 #define LETX 120 #define LETY 121 #define LETZ 122 #define LBRACE 123 #define BAR 124 #define RBRACE 125 #define TILDE 126 -h- UCSDPRIMS/close.p 393 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { xclose (UCSD) -- interface to file close } procedure xclose (fd : filedesc); begin case (cmdfil[fd]) of CLOSED, STDIO: ; { do nothing } FIL1: close(file1, LOCK); FIL2: close(file2, LOCK); FIL3: close(file3, LOCK); FIL4: close(file4, LOCK) end; cmdopen[cmdfil[fd]] := false; cmdfil[fd] := CLOSED end; -h- UCSDPRIMS/create.p 550 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { create (UCSD) -- create a file } (*$I-*) function create (var name : xstring; mode : integer) : filedesc; var fd : filedesc; snm : string; begin fd := fdalloc; if (fd <> IOERROR) then begin strname(snm, name); case (cmdfil[fd]) of FIL1: rewrite(file1, snm); FIL2: rewrite(file2, snm); FIL3: rewrite(file3, snm); FIL4: rewrite(file4, snm) end; if (ioresult <> 0) then begin xclose(fd); fd := IOERROR end end; create := fd end; (*$I+*) -h- UCSDPRIMS/endcmd.p 210 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { endcmd (UCSD) -- close all files on exit } procedure endcmd; var fd : filedesc; begin for fd := STDIN to MAXOPEN do xclose(fd) end; -h- UCSDPRIMS/fcopy.p 237 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fcopy -- copy file fin to file fout } procedure fcopy (fin, fout : filedesc); var c : character; begin while (getcf(c, fin) <> ENDFILE) do putcf(c, fout) end; -h- UCSDPRIMS/fdalloc.p 553 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fdalloc -- allocate a file descriptor } function fdalloc : filedesc; var done : boolean; fd : filedesc; begin fd := STDIN; done := false; while (not done) do if ((cmdfil[fd] = CLOSED) or (fd = MAXOPEN)) then done := true else fd := succ(fd); if (cmdfil[fd] <> CLOSED) then fdalloc := IOERROR else begin cmdfil[fd] := ftalloc; if (cmdfil[fd] = CLOSED) then fdalloc := IOERROR else begin cmdopen[cmdfil[fd]] := true; fdalloc := fd end end end; -h- UCSDPRIMS/fgetcf.p 350 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fgetcf -- get character from file } function fgetcf (var fil : text) : character; var ch : char; begin if (eof(fil)) then fgetcf := ENDFILE else if (eoln(fil)) then begin readln(fil); fgetcf := NEWLINE end else begin read(fil, ch); fgetcf := ord(ch) end; end; -h- UCSDPRIMS/fputcf.p 236 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fputcf -- put a character to file } procedure fputcf (c : character; var fil : text); begin if (c = NEWLINE) then writeln(fil) else write(fil, chr(c)) end; -h- UCSDPRIMS/ftalloc.p 360 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { ftalloc -- allocate a file } function ftalloc : filtyp; var done : boolean; ft : filtyp; begin ft := FIL1; repeat done := (not cmdopen[ft] or (ft = FIL4)); if (not done) then ft := succ(ft) until (done); if (cmdopen[ft]) then ftalloc := CLOSED else ftalloc := ft end; -h- UCSDPRIMS/getarg.p 343 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getarg (UCSD) -- get n-th command line argument into s } function getarg (n : integer; var s : xstring; maxsize : integer) : boolean; begin if ((n < 1) or (cmdargs < n)) then getarg := false else begin scopy(cmdlin, cmdidx[n], s, 1); getarg := true end end; -h- UCSDPRIMS/getc.p 212 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getc (UCSD) -- get one character from standard input } function getc (var c : character) : character; begin getc := getcf(c, STDIN) end; -h- UCSDPRIMS/getcf.p 378 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getcf (UCSD) -- get one character from file } function getcf (var c : character; fd : filedesc) : character; begin case (cmdfil[fd]) of STDIO: c := getkbd(c); FIL1: c := fgetcf(file1); FIL2: c := fgetcf(file2); FIL3: c := fgetcf(file3); FIL4: c := fgetcf(file4) end; getcf := c end; -h- UCSDPRIMS/getkbd.p 1083 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getkbd -- read character from keyboard } function getkbd (var c : character) : character; var done : boolean; ch : char; begin if (kbdn <= 0) then begin kbdnext := 1; done := false; if (kbdn = -2) then begin readln; kbdn := 0 end else if (kbdn < 0) then done := true; while (not done) do begin kbdn := kbdn + 1; done := true; if (eof) then kbdn := -1 else if (eoln) then begin kbdn := kbdn - 1; kbdline[kbdn] := NEWLINE end else if (MAXSTR-1 <= kbdn) then begin writeln('line too long'); kbdline[kbdn] := NEWLINE end else begin read(ch); kbdline[kbdn] := ord(ch); if (kbdline[kbdn] <> BACKSPACE) then { do nothing } else if (1 < kbdn) then kbdn := kbdn - 2 else kbdn := kbdn - 1; done := false end end end; if (kbdn <= 0) then c := ENDFILE else begin c := kbdline[kbdnext]; kbdnext := kbdnext + 1; if (c = NEWLINE) then kbdn := -2 else kbdn := kbdn - 1 end; getkbd := c; end; -h- UCSDPRIMS/getline.p 660 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getline (UCSD) -- get a line from file } function getline (var str : xstring; fd : filedesc; size : integer) : boolean; var i : integer; done : boolean; ch : character; begin i := 0; repeat done := true; ch := getcf(ch, fd); if (ch = ENDFILE) then i := 0 else if (ch = NEWLINE) then begin i := i + 1; str[i] := NEWLINE end else if (size-2 <= i) then begin message('line too long'); i := i + 1; str[i] := NEWLINE end else begin done := false; i := i + 1; str[i] := ch end until (done); str[i + 1] := ENDSTR; getline := (0 < i) end; -h- UCSDPRIMS/initcmd.p 1389 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { initcmd (UCSD) -- read command line and redirect files } procedure initcmd; var fd : filedesc; fname : xstring; ft : filtyp; idx : 1 .. MAXSTR; junk : boolean; begin cmdfil[STDIN] := STDIO; cmdfil[STDOUT] := STDIO; cmdfil[STDERR] := STDIO; for fd := succ(STDERR) to MAXOPEN do cmdfil[fd] := CLOSED; write('$ '); for ft := FIL1 to FIL4 do cmdopen[ft] := false; kbdn := 0; if (not getline(cmdlin, STDIN, MAXSTR)) then exit(program); cmdargs := 0; idx := 1; while ((cmdlin[idx] <> ENDSTR) and (cmdlin[idx] <> NEWLINE)) do begin while (cmdlin[idx] = BLANK) do idx := idx + 1; if (cmdlin[idx] <> NEWLINE) then begin cmdargs := cmdargs + 1; cmdidx[cmdargs] := idx; while ((cmdlin[idx] <> NEWLINE) and (cmdlin[idx] <> BLANK)) do idx := idx + 1; cmdlin[idx] := ENDSTR; idx := idx + 1; if (cmdlin[cmdidx[cmdargs]] = LESS) then begin xclose(STDIN); cmdidx[cmdargs] := cmdidx[cmdargs] + 1; junk := getarg(cmdargs, fname, MAXSTR); fd := mustopen(fname, IOREAD); cmdargs := cmdargs - 1; end else if (cmdlin[cmdidx[cmdargs]] = GREATER) then begin xclose(STDOUT); cmdidx[cmdargs] := cmdidx[cmdargs] + 1; junk := getarg(cmdargs, fname, MAXSTR); fd := mustcreate(fname, IOWRITE); cmdargs := cmdargs - 1; end end end end; -h- UCSDPRIMS/mustcreate.p 347 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { mustcreate -- create file or die } function mustcreate (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := create(name, mode); if (fd = IOERROR) then begin putstr(name, STDERR); error(': can''t create file') end; mustcreate := fd end; -h- UCSDPRIMS/mustopen.p 335 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { mustopen -- open file or die } function mustopen (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := open(name, mode); if (fd = IOERROR) then begin putstr(name, STDERR); error(': can''t open file') end; mustopen := fd end; -h- UCSDPRIMS/nargs.p 174 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { nargs (UCSD) -- return number of arguments } function nargs : integer; begin nargs := cmdargs end; -h- UCSDPRIMS/open.p 557 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { open (UCSD) -- open a file for reading or writing } (*$I-*) function open (var name : xstring; mode : integer) : filedesc; var fd : filedesc; snm : string; begin fd := fdalloc; if (fd <> IOERROR) then begin strname(snm, name); case (cmdfil[fd]) of FIL1: reset(file1, snm); FIL2: reset(file2, snm); FIL3: reset(file3, snm); FIL4: reset(file4, snm) end; if (ioresult <> 0) then begin xclose(fd); fd := IOERROR end end; open := fd end; (*$I+*) -h- UCSDPRIMS/prims.p 1899 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { prims -- external declarations for UCSD primitives } program xxx (input, output); { Copyright (c) 1981 by Bell Telephone Laboratories, Inc. and Whitesmiths, Ltd. } #include #define error(str) begin message(str); exit(program) end #define isdigit(c) ((ord('0') <= c) and (c <= ord('9'))) #define message(str) writeln(str) const IOERROR = 0; { filedesc constants } STDIN = 1; STDOUT = 2; STDERR = 3; MAXOPEN = 7; IOREAD = 0; { mode constants } IOWRITE = 1; MAXCMD = 20; { limits } MAXSTR = 100; type character = -128..127; filedesc = IOERROR..MAXOPEN; xstring = array [1..MAXSTR] of character; filtyp = (CLOSED, STDIO, FIL1, FIL2, FIL3, FIL4); var cmdargs : 0..MAXCMD; cmdidx : array [1..MAXCMD] of 1..MAXSTR; cmdlin : xstring; cmdfil : array [STDIN..MAXOPEN] of filtyp; cmdopen : array [filtyp] of boolean; file1, file2, file3, file4 : text; kbdline : xstring; kbdn : integer; kbdnext : integer; procedure scopy (var src : xstring; i : integer; var dest : xstring; j : integer); begin while (src[i] <> ENDSTR) do begin dest[j] := src[i]; i := i + 1; j := j + 1 end; dest[j] := ENDSTR end; { the primitives } #include #include #include #include #include #include #include #include #include { alias names that collide } #define close xclose #define string xstring { utilities } #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include { command line input and file redirection } #include -h- UCSDPRIMS/putc.p 189 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putc (UCSD) -- put one character on standard output } procedure putc (c : character); begin putcf(c, STDOUT) end; -h- UCSDPRIMS/putcf.p 343 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putcf (UCSD) -- put a single character on fd } procedure putcf (c : character; fd : filedesc); begin case (cmdfil[fd]) of STDIO: fputcf(c, output); FIL1: fputcf(c, file1); FIL2: fputcf(c, file2); FIL3: fputcf(c, file3); FIL4: fputcf(c, file4) end end; -h- UCSDPRIMS/putdec.p 304 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putdec -- put decimal integer n in field width >= w } procedure putdec (n, w : integer); var i, nd : integer; s : xstring; begin nd := itoc(n, s, 1); for i := nd to w do putc(BLANK); for i := 1 to nd-1 do putc(s[i]) end; -h- UCSDPRIMS/putstr.p 277 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putstr (UCSD) -- put out string on file } procedure putstr (str : xstring; fd : filedesc); var i : integer; begin i := 1; while (str[i] <> ENDSTR) do begin putcf(str[i], fd); i := i + 1 end end; -h- UCSDPRIMS/remove.p 445 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { remove -- remove a file } procedure remove (name : xstring); var fd : filedesc; begin fd := open(name, IOREAD); if (fd = IOERROR) then message('can''t remove file') else begin case (cmdfil[fd]) of FIL1: close(file1, PURGE); FIL2: close(file2, PURGE); FIL3: close(file3, PURGE); FIL4: close(file4, PURGE) end end; cmdfil[fd] := CLOSED end; -h- UCSDPRIMS/strname.p 333 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { strname -- map to native string filename } procedure strname (var str : string; var xstr : xstring); var i : integer; begin str := '.text'; i := 1; while (xstr[i] <> ENDSTR) do begin insert('x', str, i); str[i] := chr(xstr[i]); i := i + 1 end end; -h- UTIL/addstr.p 347 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { addstr -- put c in outset[j] if it fits, increment j } function addstr(c : character; var outset : string; var j : integer; maxset : integer) : boolean; begin if (j > maxset) then addstr := false else begin outset[j] := c; j := j + 1; addstr := true end end; -h- UTIL/ctoi.p 502 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { ctoi -- convert string at s[i] to integer, increment i } function ctoi (var s : string; var i : integer) : integer; var n, sign : integer; begin while (s[i] = BLANK) or (s[i] = TAB) do i := i + 1; if (s[i] = MINUS) then sign := -1 else sign := 1; if (s[i] = PLUS) or (s[i] = MINUS) then i := i + 1; n := 0; while (isdigit(s[i])) do begin n := 10 * n + s[i] - ord('0'); i := i + 1 end; ctoi := sign * n end; -h- UTIL/equal.p 303 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { equal -- test two strings for equality } function equal (var str1, str2 : string) : boolean; var i : integer; begin i := 1; while (str1[i] = str2[i]) and (str1[i] <> ENDSTR) do i := i + 1; equal := (str1[i] = str2[i]) end; -h- UTIL/esc.p 462 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { esc -- map s[i] into escaped character, increment i } function esc (var s : string; var i : integer) : character; begin if (s[i] <> ESCAPE) then esc := s[i] else if (s[i+1] = ENDSTR) then { @ not special at end } esc := ESCAPE else begin i := i + 1; if (s[i] = ord('n')) then esc := NEWLINE else if (s[i] = ord('t')) then esc := TAB else esc := s[i] end end; -h- UTIL/fcopy.p 237 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fcopy -- copy file fin to file fout } procedure fcopy (fin, fout : filedesc); var c : character; begin while (getcf(c, fin) <> ENDFILE) do putcf(c, fout) end; -h- UTIL/globdefs.p 2030 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { globdefs (UCB) -- global constants, types and variables } const { standard file descriptors. subscripts in open, etc. } STDIN = 1; { these are not to be changed } STDOUT = 2; STDERR = 3; { other io-related stuff } IOERROR = 0; { status values for open files } IOAVAIL = 1; IOREAD = 2; IOWRITE = 3; MAXOPEN = 10; { maximum number of open files } { universal manifest constants } ENDFILE = -1; ENDSTR = 0; { null-terminated strings } MAXSTR = 100; { longest possible string } { ascii character set in decimal } BACKSPACE = 8; TAB = 9; NEWLINE = 10; BLANK = 32; EXCLAM = 33; { ! } DQUOTE = 34; { " } SHARP = 35; { # } DOLLAR = 36; { $ } PERCENT = 37; { % } AMPER = 38; { & } SQUOTE = 39; { ' } ACUTE = SQUOTE; LPAREN = 40; { ( } RPAREN = 41; { ) } STAR = 42; { * } PLUS = 43; { + } COMMA = 44; { , } MINUS = 45; { - } DASH = MINUS; PERIOD = 46; { . } SLASH = 47; { / } COLON = 58; { : } SEMICOL = 59; { ; } LESS = 60; { < } EQUALS = 61; { = } GREATER = 62; { > } QUESTION = 63; { ? } ATSIGN = 64; { @ } ESCAPE = ATSIGN; LBRACK = 91; { [ } BACKSLASH = 92; { \e } RBRACK = 93; { ] } CARET = 94; { ^ } UNDERLINE = 95; { _ } GRAVE = 96; { ` } LETA = 97; { lower case ... } LETB = 98; LETC = 99; LETD = 100; LETE = 101; LETF = 102; LETG = 103; LETH = 104; LETI = 105; LETJ = 106; LETK = 107; LETL = 108; LETM = 109; LETN = 110; LETO = 111; LETP = 112; LETQ = 113; LETR = 114; LETS = 115; LETT = 116; LETU = 117; LETV = 118; LETW = 119; LETX = 120; LETY = 121; LETZ = 122; LBRACE = 123; { left brace } BAR = 124; { | } RBRACE = 125; { right brace } TILDE = 126; { ~ } type character = -1..127; { byte-sized. ascii + other stuff } string = array [1..MAXSTR] of character; filedesc = IOERROR..MAXOPEN; ioblock = record { to keep track of open files } filevar : text; mode : IOERROR..IOWRITE; end; var openlist : array [1..MAXOPEN] of ioblock; { open files } -h- UTIL/index.p 336 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { index -- find position of character c in string s } function index (var s : string; c : character) : integer; var i : integer; begin i := 1; while (s[i] <> c) and (s[i] <> ENDSTR) do i := i + 1; if (s[i] = ENDSTR) then index := 0 else index := i end; -h- UTIL/isalphanum.p 266 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { isalphanum -- true if c is letter or digit } function isalphanum (c : character) : boolean; begin isalphanum := c in [ord('a')..ord('z'), ord('A')..ord('Z'), ord('0')..ord('9')] end; -h- UTIL/isdigit.p 201 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { isdigit -- true if c is a digit } function isdigit (c : character) : boolean; begin isdigit := c in [ord('0')..ord('9')] end; -h- UTIL/isletter.p 245 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { isletter -- true if c is a letter of either case } function isletter (c : character) : boolean; begin isletter := c in [ord('a')..ord('z')] + [ord('A')..ord('Z')] end; -h- UTIL/islower.p 211 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { islower -- true if c is lower case letter } function islower (c : character) : boolean; begin islower := c in [ord('a')..ord('z')] end; -h- UTIL/isupper.p 211 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { isupper -- true if c is upper case letter } function isupper (c : character) : boolean; begin isupper := c in [ord('A')..ord('Z')] end; -h- UTIL/itoc.p 438 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { itoc - convert integer n to char string in s[i]... } function itoc (n : integer; var s : string; i : integer) : integer; { returns end of s } begin if (n < 0) then begin s[i] := ord('-'); itoc := itoc(-n, s, i+1) end else begin if (n >= 10) then i := itoc(n div 10, s, i); s[i] := n mod 10 + ord('0'); s[i+1] := ENDSTR; itoc := i + 1 end end; -h- UTIL/itoctest.p 312 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } procedure itoctest; var i, n, d : integer; s : string; begin while (getline(s, STDIN, MAXSTR)) do begin i := 1; n := ctoi(s, i); d := itoc(n, s, 1); putstr(s, STDOUT); putdec(n, 10); putdec(d, 10); putc(NEWLINE); end end; -h- UTIL/length.p 251 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { length -- compute length of string } function length (var s : string) : integer; var n : integer; begin n := 1; while (s[n] <> ENDSTR) do n := n + 1; length := n - 1 end; -h- UTIL/max.p 212 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { max -- compute maximum of two integers } function max (x, y : integer) : integer; begin if (x > y) then max := x else max := y end; -h- UTIL/min.p 212 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { min -- compute minimum of two integers } function min (x, y : integer) : integer; begin if (x < y) then min := x else min := y end; -h- UTIL/mustcreate.p 347 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { mustcreate -- create file or die } function mustcreate (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := create(name, mode); if (fd = IOERROR) then begin putstr(name, STDERR); error(': can''t create file') end; mustcreate := fd end; -h- UTIL/mustopen.p 335 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { mustopen -- open file or die } function mustopen (var name : string; mode : integer) : filedesc; var fd : filedesc; begin fd := open(name, mode); if (fd = IOERROR) then begin putstr(name, STDERR); error(': can''t open file') end; mustopen := fd end; -h- UTIL/putdec.p 303 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putdec -- put decimal integer n in field width >= w } procedure putdec (n, w : integer); var i, nd : integer; s : string; begin nd := itoc(n, s, 1); for i := nd to w do putc(BLANK); for i := 1 to nd-1 do putc(s[i]) end; -h- UTIL/scopy.p 320 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { scopy -- copy string at src[i] to dest[j] } procedure scopy (var src : string; i : integer; var dest : string; j : integer); begin while (src[i] <> ENDSTR) do begin dest[j] := src[i]; i := i + 1; j := j + 1 end; dest[j] := ENDSTR end; -h- UTIL/utility.p 507 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { utility -- generally useful functions and procedures } #include "addstr.p" #include "equal.p" #include "esc.p" #include "index.p" #include "isalphanum.p" #include "isdigit.p" #include "isletter.p" #include "islower.p" #include "isupper.p" #include "itoc.p" #include "length.p" #include "max.p" #include "min.p" #include "scopy.p" #include "ctoi.p" #include "fcopy.p" #include "mustcreate.p" #include "mustopen.p" #include "putdec.p" -h- INTRO/charcount.p 279 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { charcount -- count characters in standard input } procedure charcount; var nc : integer; c : character; begin nc := 0; while (getc(c) <> ENDFILE) do nc := nc + 1; putdec(nc, 1); putc(NEWLINE) end; -h- INTRO/copy.p 193 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { copy -- copy input to output } procedure copy; var c : character; begin while (getc(c) <> ENDFILE) do putc(c) end; -h- INTRO/detab.p 648 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { detab -- convert tabs to equivalent number of blanks } procedure detab; const MAXLINE = 1000; { or whatever } type tabtype = array [1..MAXLINE] of boolean; var c : character; col : integer; tabstops : tabtype; #include "tabpos.p" #include "settabs.p" begin settabs(tabstops); { set initial tab stops } col := 1; while (getc(c) <> ENDFILE) do if (c = TAB) then repeat putc(BLANK); col := col + 1 until (tabpos(col, tabstops)) else if (c = NEWLINE) then begin putc(NEWLINE); col := 1 end else begin putc(c); col := col + 1 end end; -h- INTRO/linecount.p 299 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { linecount -- count lines in standard input } procedure linecount; var nl : integer; c : character; begin nl := 0; while (getc(c) <> ENDFILE) do if (c = NEWLINE) then nl := nl + 1; putdec(nl, 1); putc(NEWLINE) end; -h- INTRO/settabs.p 288 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { settabs -- set initial tab stops } procedure settabs (var tabstops : tabtype); const TABSPACE = 4; { 4 spaces per tab } var i : integer; begin for i := 1 to MAXLINE do tabstops[i] := (i mod TABSPACE = 1) end; -h- INTRO/tabpos.p 273 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { tabpos -- return true if col is a tab stop } function tabpos (col : integer; var tabstops : tabtype) : boolean; begin if (col > MAXLINE) then tabpos := true else tabpos := tabstops[col] end; -h- INTRO/wholecopy.p 839 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { complete copy -- to show one possible implementation } program copyprog (input, output); const ENDFILE = -1; NEWLINE = 10; { ASCII value } type character = -1..127; { ASCII, plus ENDFILE } { getc -- get one character from standard input } function getc (var c : character) : character; var ch : char; begin if (eof) then c := ENDFILE else if (eoln) then begin readln; c := NEWLINE end else begin read(ch); c := ord(ch) end; getc := c end; { putc -- put one character on standard output } procedure putc (c : character); begin if (c = NEWLINE) then writeln else write(chr(c)) end; { copy -- copy input to output } procedure copy; var c : character; begin while (getc(c) <> ENDFILE) do putc(c) end; begin { main program } copy end. -h- INTRO/wordcount.p 442 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { wordcount -- count words in standard input } procedure wordcount; var nw : integer; c : character; inword : boolean; begin nw := 0; inword := false; while (getc(c) <> ENDFILE) do if (c = BLANK) or (c = NEWLINE) or (c = TAB) then inword := false else if (not inword) then begin inword := true; nw := nw + 1 end; putdec(nw, 1); putc(NEWLINE) end; -h- FILTERS/compress.p 597 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { compress -- compress standard input } procedure compress; const WARNING = TILDE; { ~ } var c, lastc : character; n : integer; #include "putrep.p" begin n := 1; lastc := getc(lastc); while (lastc <> ENDFILE) do begin if (getc(c) = ENDFILE) then begin if (n > 1) or (lastc = WARNING) then putrep(n, lastc) else putc(lastc) end else if (c = lastc) then n := n + 1 else if (n > 1) or (lastc = WARNING) then begin putrep(n, lastc); n := 1 end else putc(lastc); lastc := c end end; -h- FILTERS/echo.p 381 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { echo -- echo command line arguments to output } procedure echo; var i, j : integer; argstr : string; begin i := 1; while (getarg(i, argstr, MAXSTR)) do begin if (i > 1) then putc(BLANK); for j := 1 to length(argstr) do putc(argstr[j]); i := i + 1 end; if (i > 1) then putc(NEWLINE) end; -h- FILTERS/entab.p 802 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { entab -- replace blanks by tabs and blanks } procedure entab; const MAXLINE = 1000; { or whatever } type tabtype = array [1..MAXLINE] of boolean; var c : character; col, newcol : integer; tabstops : tabtype; #include "tabpos.p" #include "settabs.p" begin settabs(tabstops); col := 1; repeat newcol := col; while (getc(c) = BLANK) do begin { collect blanks } newcol := newcol + 1; if (tabpos(newcol, tabstops)) then begin putc(TAB); col := newcol end end; while (col < newcol) do begin putc(BLANK); { output leftover blanks } col := col + 1 end; if (c <> ENDFILE) then begin putc(c); if (c = NEWLINE) then col := 1 else col := col + 1 end until (c = ENDFILE) end; -h- FILTERS/expand.p 558 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { expand -- uncompress standard input } procedure expand; const WARNING = TILDE; { ~ } var c : character; n : integer; begin while (getc(c) <> ENDFILE) do if (c <> WARNING) then putc(c) else if (isupper(getc(c))) then begin n := c - ord('A') + 1; if (getc(c) <> ENDFILE) then for n := n downto 1 do putc(c) else begin putc(WARNING); putc(n - 1 + ord('A')) end end else begin putc(WARNING); if (c <> ENDFILE) then putc(c) end end; -h- FILTERS/overstrike.p 788 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { overstrike -- convert backspaces into multiple lines } procedure overstrike; const SKIP = BLANK; NOSKIP = PLUS; var c : character; col, newcol, i : integer; begin col := 1; repeat newcol := col; while (getc(c) = BACKSPACE) do { eat backspaces } newcol := max(newcol-1, 1); if (newcol < col) then begin putc(NEWLINE); { start overstrike line } putc(NOSKIP); for i := 1 to newcol-1 do putc(BLANK); col := newcol end else if (col = 1) and (c <> ENDFILE) then putc(SKIP); { normal line } { else middle of line } if (c <> ENDFILE) then begin putc(c); { normal character } if (c = NEWLINE) then col := 1 else col := col + 1 end until (c = ENDFILE) end; -h- FILTERS/putrep.p 425 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putrep -- put out representation of run of n 'c's } procedure putrep (n : integer; c : character); const MAXREP = 26; { assuming 'A'..'Z' } THRESH = 4; begin while (n >= THRESH) or ((c = WARNING) and (n > 0)) do begin putc(WARNING); putc(min(n, MAXREP) - 1 + ord('A')); putc(c); n := n - MAXREP end; for n := n downto 1 do putc(c) end; -h- FILTERS/settabs.p 288 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { settabs -- set initial tab stops } procedure settabs (var tabstops : tabtype); const TABSPACE = 4; { 4 spaces per tab } var i : integer; begin for i := 1 to MAXLINE do tabstops[i] := (i mod TABSPACE = 1) end; -h- FILTERS/tabpos.p 273 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { tabpos -- return true if col is a tab stop } function tabpos (col : integer; var tabstops : tabtype) : boolean; begin if (col > MAXLINE) then tabpos := true else tabpos := tabstops[col] end; -h- TRANSLIT/dodash.p 891 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dodash - expand set at src[i] into dest[j], stop at delim } procedure dodash (delim : character; var src : string; var i : integer; var dest : string; var j : integer; maxset : integer); var k : integer; junk : boolean; begin while (src[i] <> delim) and (src[i] <> ENDSTR) do begin if (src[i] = ESCAPE) then junk := addstr(esc(src, i), dest, j, maxset) else if (src[i] <> DASH) then junk := addstr(src[i], dest, j, maxset) else if (j <= 1) or (src[i+1] = ENDSTR) then junk := addstr(DASH,dest,j,maxset) { literal - } else if (isalphanum(src[i-1])) and (isalphanum(src[i+1])) and (src[i-1] <= src[i+1]) then begin for k := src[i-1]+1 to src[i+1] do junk := addstr(k, dest, j, maxset); i := i + 1 end else junk := addstr(DASH, dest, j, maxset); i := i + 1 end end; -h- TRANSLIT/makeset.p 373 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { makeset -- make set from inset[k] in outset } function makeset (var inset : string; k : integer; var outset : string; maxset : integer) : boolean; var j : integer; #include "dodash.p" begin j := 1; dodash(ENDSTR, inset, k, outset, j, maxset); makeset := addstr(ENDSTR, outset, j, maxset) end; -h- TRANSLIT/translit.p 1292 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { translit -- map characters } procedure translit; const NEGATE = CARET; { ^ } var arg, fromset, toset : string; c : character; i, lastto : 0..MAXSTR; allbut, squash : boolean; #include "makeset.p" #include "xindex.p" begin if (not getarg(1, arg, MAXSTR)) then error('usage: translit from to'); allbut := (arg[1] = NEGATE); if (allbut) then i := 2 else i := 1; if (not makeset(arg, i, fromset, MAXSTR)) then error('translit: "from" set too large'); if (not getarg(2, arg, MAXSTR)) then toset[1] := ENDSTR else if (not makeset(arg, 1, toset, MAXSTR)) then error('translit: "to" set too large') else if (length(fromset) < length(toset)) then error('translit: "from" shorter than "to"'); lastto := length(toset); squash := (length(fromset) > lastto) or (allbut); repeat i := xindex(fromset, getc(c), allbut, lastto); if (squash) and (i>=lastto) and (lastto>0) then begin putc(toset[lastto]); repeat i := xindex(fromset, getc(c), allbut, lastto) until (i < lastto) end; if (c <> ENDFILE) then begin if (i > 0) and (lastto > 0) then { translate } putc(toset[i]) else if (i = 0) then { copy } putc(c) { else delete } end until (c = ENDFILE) end; -h- TRANSLIT/xindex.p 410 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { xindex -- conditionally invert value from index } function xindex (var inset : string; c : character; allbut : boolean; lastto : integer) : integer; begin if (c = ENDFILE) then xindex := 0 else if (not allbut) then xindex := index(inset, c) else if (index(inset, c) > 0) then xindex := 0 else xindex := lastto + 1 end; -h- FILEIO/compare.p 872 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { compare -- compare two files for equality } procedure compare; var line1, line2 : string; arg1, arg2 : string; lineno : integer; infile1, infile2 : filedesc; f1, f2 : boolean; #include "diffmsg.p" begin if (not getarg(1, arg1, MAXSTR)) or (not getarg(2, arg2, MAXSTR)) then error('usage: compare file1 file2'); infile1 := mustopen(arg1, IOREAD); infile2 := mustopen(arg2, IOREAD); lineno := 0; repeat lineno := lineno + 1; f1 := getline(line1, infile1, MAXSTR); f2 := getline(line2, infile2, MAXSTR); if (f1 and f2) then if (not equal(line1, line2)) then diffmsg(lineno, line1, line2) until (f1 = false) or (f2 = false); if (f2 and not f1) then message('compare: end of file on file1') else if (f1 and not f2) then message('compare: end of file on file2') end; -h- FILEIO/compare0.p 651 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { compare (simple version) -- compare two files for equality } procedure compare; var line1, line2 : string; lineno : integer; f1, f2 : boolean; #include "diffmsg.p" begin lineno := 0; repeat lineno := lineno + 1; f1 := getline(line1, infile1, MAXSTR); f2 := getline(line2, infile2, MAXSTR); if (f1 and f2) then if (not equal(line1, line2)) then diffmsg(lineno, line1, line2) until (f1 = false) or (f2 = false); if (f2 and not f1) then message('compare: end of file on file1') else if (f1 and not f2) then message('compare: end of file on file2') end; -h- FILEIO/concat.p 347 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { concat -- concatenate files onto standard output } procedure concat; var i : integer; junk : boolean; fd : filedesc; s : string; begin for i := 1 to nargs do begin junk := getarg(i, s, MAXSTR); fd := mustopen(s, IOREAD); fcopy(fd, STDOUT); close(fd) end end; -h- FILEIO/dcompare.p 424 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dcompare -- drive simple version of compare } procedure dcompare; var arg1, arg2 : string; infile1, infile2 : filedesc; #include "compare0.p" begin if (not getarg(1, arg1, MAXSTR)) or (not getarg(2, arg2, MAXSTR)) then error('usage: compare file1 file2'); infile1 := mustopen(arg1, IOREAD); infile2 := mustopen(arg2, IOREAD); compare end; -h- FILEIO/diffmsg.p 289 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { diffmsg -- print line numbers and differing lines } procedure diffmsg (n : integer; var line1, line2 : string); begin putdec(n, 1); putc(COLON); putc(NEWLINE); putstr(line1, STDOUT); putstr(line2, STDOUT) end; -h- FILEIO/finclude.p 594 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { finclude -- include file desc f } procedure finclude (f : filedesc); var line, str : string; loc, i : integer; f1 : filedesc; #include "getword.p" begin while (getline(line, f, MAXSTR)) do begin loc := getword(line, 1, str); if (not equal(str, incl)) then putstr(line, STDOUT) else begin loc := getword(line, loc, str); str[length(str)] := ENDSTR; { remove quotes } for i := 1 to length(str) do str[i] := str[i+1]; f1 := mustopen(str, IOREAD); finclude(f1); close(f1) end end end; -h- FILEIO/getword.p 478 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getword -- get word from s[i] into out } function getword (var s : string; i : integer; var out : string) : integer; var j : integer; begin while (s[i] in [BLANK, TAB, NEWLINE]) do i := i + 1; j := 1; while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin out[j] := s[i]; i := i + 1; j := j + 1 end; out[j] := ENDSTR; if (s[i] = ENDSTR) then getword := 0 else getword := i end; -h- FILEIO/include.p 483 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { include -- replace #include "file" by contents of file } procedure include; var incl : string; { value is '#include' } #include "finclude.p" begin { setstring(incl, '#include'); } incl[1] := ord('#'); incl[2] := ord('i'); incl[3] := ord('n'); incl[4] := ord('c'); incl[5] := ord('l'); incl[6] := ord('u'); incl[7] := ord('d'); incl[8] := ord('e'); incl[9] := ENDSTR; finclude(STDIN) end; -h- FILEIO/makecopy.p 432 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { makecopy -- copy one file to another } procedure makecopy; var inname, outname : string; fin, fout : filedesc; begin if (not getarg(1, inname, MAXSTR)) or (not getarg(2, outname, MAXSTR)) then error('usage: makecopy old new'); fin := mustopen(inname, IOREAD); fout := mustcreate(outname, IOWRITE); fcopy(fin, fout); close(fin); close(fout) end; -h- PRINT/fprint.p 806 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fprint -- print file "name" from fin } procedure fprint (var name : string; fin : filedesc); const MARGIN1 = 2; MARGIN2 = 2; BOTTOM = 64; PAGELEN = 66; var line : string; lineno, pageno : integer; #include "skip.p" #include "head.p" begin pageno := 1; skip(MARGIN1); head(name, pageno); skip(MARGIN2); lineno := MARGIN1 + MARGIN2 + 1; while (getline(line, fin, MAXSTR)) do begin if (lineno = 0) then begin skip(MARGIN1); pageno := pageno + 1; head(name, pageno); skip(MARGIN2); lineno := MARGIN1 + MARGIN2 + 1 end; putstr(line, STDOUT); lineno := lineno + 1; if (lineno >= BOTTOM) then begin skip(PAGELEN-lineno); lineno := 0 end end; if (lineno > 0) then skip(PAGELEN-lineno) end; -h- PRINT/head.p 486 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { head -- print top of page header } procedure head (var name : string; pageno : integer); var page : string; { set to ' Page ' } begin { setstring(page, ' Page '); } page[1] := ord(' '); page[2] := ord('P'); page[3] := ord('a'); page[4] := ord('g'); page[5] := ord('e'); page[6] := ord(' '); page[7] := ENDSTR; putstr(name, STDOUT); putstr(page, STDOUT); putdec(pageno, 1); putc(NEWLINE) end; -h- PRINT/print.p 517 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { print (default input STDIN) -- print files with headings } procedure print; var name : string; null : string; { value '' } i : integer; fin : filedesc; junk : boolean; #include "fprint.p" begin { setstring(null, ''); } null[1] := ENDSTR; if (nargs = 0) then fprint(null, STDIN) else for i := 1 to nargs do begin junk := getarg(i, name, MAXSTR); fin := mustopen(name, IOREAD); fprint(name, fin); close(fin) end end; -h- PRINT/print0.p 364 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { print -- print files with headings } procedure print; var name : string; i : integer; fin : filedesc; junk : boolean; #include "fprint.p" begin for i := 1 to nargs do begin junk := getarg(i, name, MAXSTR); fin := mustopen(name, IOREAD); fprint(name, fin); close(fin) end end; -h- PRINT/skip.p 200 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { skip -- output n blank lines } procedure skip (n : integer); var i : integer; begin for i := 1 to n do putc(NEWLINE) end; -h- ARCHIVE/acopy.p 338 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { acopy -- copy n characters from fdi to fdo } procedure acopy (fdi, fdo : filedesc; n : integer); var c : character; i : integer; begin for i := 1 to n do if (getcf(c, fdi) = ENDFILE) then error('archive: end of file in acopy') else putcf(c, fdo) end; -h- ARCHIVE/addfile.p 489 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { addfile -- add file "name" to archive } procedure addfile (var name : string; fd : filedesc); var head : string; nfd : filedesc; #include "makehdr.p" begin nfd := open(name, IOREAD); if (nfd = IOERROR) then begin putstr(name, STDERR); message(': can''t add'); errcount := errcount + 1 end; if (errcount = 0) then begin makehdr(name, head); putstr(head, fd); fcopy(nfd, fd); close(nfd) end end; -h- ARCHIVE/archive.p 1011 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { archive -- file maintainer } procedure archive; const MAXFILES = 100; { or whatever } var aname : string; { archive name } cmd : string; { command type } fname : array [1..MAXFILES] of string; { filename args } fstat : array [1..MAXFILES] of boolean; { true=in archive } nfiles : integer; { number of filename arguments } errcount : integer; { number of errors } archtemp : string; { temp file name 'artemp' } archhdr : string; { header string '-h-' } #include "archproc.p" begin initarch; if (not getarg(1, cmd, MAXSTR)) or (not getarg(2, aname, MAXSTR)) then help; getfns; if (length(cmd) <> 2) or (cmd[1] <> ord('-')) then help else if (cmd[2] = ord('c')) or (cmd[2] = ord('u')) then update(aname, cmd[2]) else if (cmd[2] = ord('t')) then table(aname) else if (cmd[2] = ord('x')) or (cmd[2] = ord('p')) then extract(aname, cmd[2]) else if (cmd[2] = ord('d')) then delete(aname) else help end; -h- ARCHIVE/archproc.p 442 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { archproc -- include procedures for archive } #include "getword.p" #include "gethdr.p" #include "filearg.p" #include "fskip.p" #include "fmove.p" #include "acopy.p" #include "notfound.p" #include "addfile.p" #include "replace.p" #include "help.p" #include "getfns.p" #include "update.p" #include "table.p" #include "extract.p" #include "delete.p" #include "initarch.p" -h- ARCHIVE/delete.p 549 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { delete -- delete files from archive } procedure delete (var aname : string); var afd, tfd : filedesc; begin if (nfiles <= 0) then { protect innocents } error('archive: -d requires explicit file names'); afd := mustopen(aname, IOREAD); tfd := mustcreate(archtemp, IOWRITE); replace(afd, tfd, ord('d')); notfound; close(afd); close(tfd); if (errcount = 0) then fmove(archtemp, aname) else message('fatal errors - archive not altered'); remove(archtemp) end; -h- ARCHIVE/extract.p 799 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { extract -- extract files from archive } procedure extract (var aname: string; cmd : character); var ename, inline : string; afd, efd : filedesc; size : integer; begin afd := mustopen(aname, IOREAD); if (cmd = ord('p')) then efd := STDOUT else { cmd is 'x' } efd := IOERROR; while (gethdr(afd, inline, ename, size)) do if (not filearg(ename)) then fskip(afd, size) else begin if (efd <> STDOUT) then efd := create(ename, IOWRITE); if (efd = IOERROR) then begin putstr(ename, STDERR); message(': can''t create'); errcount := errcount + 1; fskip(afd, size) end else begin acopy(afd, efd, size); if (efd <> STDOUT) then close(efd) end end; notfound end; -h- ARCHIVE/filearg.p 480 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { filearg -- check if name matches argument list } function filearg (var name : string) : boolean; var i : integer; found : boolean; begin if (nfiles <= 0) then filearg := true else begin found := false; i := 1; while (not found) and (i <= nfiles) do begin if (equal(name, fname[i])) then begin fstat[i] := true; found := true end; i := i + 1 end; filearg := found end end; -h- ARCHIVE/fmove.p 304 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fmove -- move file name1 to name2 } procedure fmove (var name1, name2 : string); var fd1, fd2 : filedesc; begin fd1 := mustopen(name1, IOREAD); fd2 := mustcreate(name2, IOWRITE); fcopy(fd1, fd2); close(fd1); close(fd2) end; -h- ARCHIVE/fsize.p 333 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fsize -- size of file in characters } function fsize (var name : string) : integer; var c : character; fd : filedesc; n : integer; begin n := 0; fd := mustopen(name, IOREAD); while (getcf(c, fd) <> ENDFILE) do n := n + 1; close(fd); fsize := n end; -h- ARCHIVE/fskip.p 302 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fskip -- skip n characters on file fd } procedure fskip (fd : filedesc; n : integer); var c : character; i : integer; begin for i := 1 to n do if (getcf(c, fd) = ENDFILE) then error('archive: end of file in fskip') end; -h- ARCHIVE/getfns.p 595 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getfns -- get filenames into fname, look for duplicates } procedure getfns; var i, j : integer; junk : boolean; begin errcount := 0; nfiles := nargs - 2; if (nfiles > MAXFILES) then error('archive: too many file names'); for i := 1 to nfiles do junk := getarg(i+2, fname[i], MAXSTR); for i := 1 to nfiles do fstat[i] := false; for i := 1 to nfiles - 1 do for j := i + 1 to nfiles do if (equal(fname[i], fname[j])) then begin putstr(fname[i], STDERR); error(': duplicate file name') end end; -h- ARCHIVE/gethdr.p 504 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gethdr -- get header info from fd } function gethdr (fd : filedesc; var buf, name : string; var size : integer) : boolean; var temp : string; i : integer; begin if (getline(buf, fd, MAXSTR) = false) then gethdr := false else begin i := getword(buf, 1, temp); if (not equal(temp, archhdr)) then error('archive not in proper format'); i := getword(buf, i, name); size := ctoi(buf, i); gethdr := true end end; -h- ARCHIVE/getword.p 478 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getword -- get word from s[i] into out } function getword (var s : string; i : integer; var out : string) : integer; var j : integer; begin while (s[i] in [BLANK, TAB, NEWLINE]) do i := i + 1; j := 1; while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin out[j] := s[i]; i := i + 1; j := j + 1 end; out[j] := ENDSTR; if (s[i] = ENDSTR) then getword := 0 else getword := i end; -h- ARCHIVE/help.p 195 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { help -- print diagnostic for archive } procedure help; begin error('usage: archive -[cdptux] archname [files...]') end; -h- ARCHIVE/initarch.p 509 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { initarch -- initialize variables for archive } procedure initarch; begin { setstring(archtemp, 'artemp'); } archtemp[1] := ord('a'); archtemp[2] := ord('r'); archtemp[3] := ord('t'); archtemp[4] := ord('e'); archtemp[5] := ord('m'); archtemp[6] := ord('p'); archtemp[7] := ENDSTR; { setstring(archhdr, '-h-'); } archhdr[1] := ord('-'); archhdr[2] := ord('h'); archhdr[3] := ord('-'); archhdr[4] := ENDSTR; end; -h- ARCHIVE/makehdr.p 437 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { makehdr -- make header line for archive member } procedure makehdr (var name, head : string); var i : integer; #include "fsize.p" begin scopy(archhdr, 1, head, 1); i := length(head) + 1; head[i] := BLANK; scopy(name, 1, head, i+1); i := length(head) + 1; head[i] := BLANK; i := itoc(fsize(name), head, i+1); head[i] := NEWLINE; head[i+1] := ENDSTR end; -h- ARCHIVE/notfound.p 318 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { notfound -- print "not found" warning } procedure notfound; var i : integer; begin for i := 1 to nfiles do if (fstat[i] = false) then begin putstr(fname[i], STDERR); message(': not in archive'); errcount := errcount + 1 end end; -h- ARCHIVE/replace.p 487 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { replace -- replace or delete files } procedure replace (afd, tfd : filedesc; cmd : integer); var inline, uname : string; size : integer; begin while (gethdr(afd, inline, uname, size)) do if (filearg(uname)) then begin if (cmd = ord('u')) then { add new one } addfile(uname, tfd); fskip(afd, size) { discard old one } end else begin putstr(inline, tfd); acopy(afd, tfd, size) end end; -h- ARCHIVE/table.p 406 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { table -- print table of archive contents } procedure table (var aname : string); var head, name : string; size : integer; afd : filedesc; #include "tprint.p" begin afd := mustopen(aname, IOREAD); while (gethdr(afd, head, name, size)) do begin if (filearg(name)) then tprint(head); fskip(afd, size) end; notfound end; -h- ARCHIVE/tprint.p 392 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { tprint -- print table entry for one member } procedure tprint (var buf : string); var i : integer; temp : string; begin i := getword(buf, 1, temp); { header } i := getword(buf, i, temp); { name } putstr(temp, STDOUT); putc(BLANK); i := getword(buf, i, temp); { size } putstr(temp, STDOUT); putc(NEWLINE) end; -h- ARCHIVE/update.p 679 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { update -- update existing files, add new ones at end } procedure update (var aname : string; cmd : character); var i : integer; afd, tfd : filedesc; begin tfd := mustcreate(archtemp, IOWRITE); if (cmd = ord('u')) then begin afd := mustopen(aname, IOREAD); replace(afd, tfd, ord('u')); { update existing } close(afd) end; for i := 1 to nfiles do { add new ones } if (fstat[i] = false) then begin addfile(fname[i], tfd); fstat[i] := true end; close(tfd); if (errcount = 0) then fmove(archtemp, aname) else message('fatal errors - archive not altered'); remove(archtemp) end; -h- SORT/bubble.p 371 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { bubble -- bubble sort v[1] ... v[n] increasing } procedure bubble (var v : intarray; n : integer); var i, j, k : integer; begin for i := n downto 2 do for j := 1 to i-1 do if (v[j] > v[j+1]) then begin { compare } k := v[j]; { exchange } v[j] := v[j+1]; v[j+1] := k end end; -h- SORT/cmp.p 551 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { cmp -- compare linebuf[i] with linebuf[j] } function cmp (i, j : charpos; var linebuf : charbuf) : integer; begin while (linebuf[i] = linebuf[j]) and (linebuf[i] <> ENDSTR) do begin i := i + 1; j := j + 1 end; if (linebuf[i] = linebuf[j]) then cmp := 0 else if (linebuf[i] = ENDSTR) then { 1st is shorter } cmp := -1 else if (linebuf[j] = ENDSTR) then { 2nd is shorter } cmp := +1 else if (linebuf[i] < linebuf[j]) then cmp := -1 else cmp := +1 end; -h- SORT/cscopy.p 318 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { cscopy -- copy cb[i]... to string s } procedure cscopy (var cb : charbuf; i : charpos; var s : string); var j : integer; begin j := 1; while (cb[i] <> ENDSTR) do begin s[j] := cb[i]; i := i + 1; j := j + 1 end; s[j] := ENDSTR end; -h- SORT/exchange.p 245 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { exchange -- exchange linebuf[lp1] with linebuf[lp2] } procedure exchange (var lp1, lp2 : charpos); var temp : charpos; begin temp := lp1; lp1 := lp2; lp2 := temp end; -h- SORT/gname.p 408 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gname -- generate unique name for file id n } procedure gname (n : integer; var name : string); var junk : integer; begin { setstring(name, 'stemp'); } name[1] := ord('s'); name[2] := ord('t'); name[3] := ord('e'); name[4] := ord('m'); name[5] := ord('p'); name[6] := ENDSTR; junk := itoc(n, name, length(name)+1) end; -h- SORT/gopen.p 320 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gopen -- open group of files f1 ... f2 } procedure gopen (var infile : fdbuf; f1, f2 : integer); var name : string; i : 1..MERGEORDER; begin for i := 1 to f2-f1+1 do begin gname(f1+i-1, name); infile[i] := mustopen(name, IOREAD) end end; -h- SORT/gremove.p 323 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gremove -- remove group of files f1 ... f2 } procedure gremove (var infile : fdbuf; f1, f2 : integer); var name : string; i : 1..MERGEORDER; begin for i := 1 to f2-f1+1 do begin close(infile[i]); gname(f1+i-1, name); remove(name) end end; -h- SORT/gtext.p 736 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gtext -- get text lines into linebuf } function gtext (var linepos : posbuf; var nlines : pos; var linebuf : charbuf; infile : filedesc) : boolean; var i, len, nextpos : integer; temp : string; done : boolean; begin nlines := 0; nextpos := 1; repeat done := (getline(temp, infile, MAXSTR) = false); if (not done) then begin nlines := nlines + 1; linepos[nlines] := nextpos; len := length(temp); for i := 1 to len do linebuf[nextpos+i-1] := temp[i]; linebuf[nextpos+len] := ENDSTR; nextpos := nextpos + len + 1 { 1 for ENDSTR } end until (done) or (nextpos >= MAXCHARS-MAXSTR) or (nlines >= MAXLINES); gtext := done end; -h- SORT/inmemquick.p 684 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { sort -- sort text lines in memory } procedure inmemquick; const MAXCHARS = 10000; { maximum # of text characters } MAXLINES = 100; { maximum # of line pointers } type charpos = 1..MAXCHARS; charbuf = array [1..MAXCHARS] of character; posbuf = array [1..MAXLINES] of charpos; pos = 0..MAXLINES; var linebuf : charbuf; linepos : posbuf; nlines : pos; #include "gtext.p" #include "quick.p" #include "ptext.p" begin if (gtext(linepos, nlines, linebuf, STDIN)) then begin quick(linepos, nlines, linebuf); ptext(linepos, nlines, linebuf, STDOUT) end else error('sort: input too big to sort') end; -h- SORT/inmemsort.p 675 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { sort -- sort text lines in memory } procedure inmemsort; const MAXCHARS = 10000; { maximum # of text characters } MAXLINES = 300; { maximum # of lines } type charbuf = array [1..MAXCHARS] of character; charpos = 1..MAXCHARS; posbuf = array [1..MAXLINES] of charpos; pos = 0..MAXLINES; var linebuf : charbuf; linepos : posbuf; nlines : pos; #include "gtext.p" #include "shell.p" #include "ptext.p" begin if (gtext(linepos, nlines, linebuf, STDIN)) then begin shell(linepos, nlines, linebuf); ptext(linepos, nlines, linebuf, STDOUT) end else error('sort: input too big to sort') end; -h- SORT/kwic.p 257 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { kwic -- make keyword in context index } procedure kwic; const FOLD = DOLLAR; var buf : string; #include "putrot.p" begin while (getline(buf, STDIN, MAXSTR)) do putrot(buf) end; -h- SORT/makefile.p 246 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { makefile -- make new file for number n } function makefile (n : integer) : filedesc; var name : string; begin gname(n, name); makefile := mustcreate(name, IOWRITE) end; -h- SORT/merge.p 993 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { merge -- merge infile[1] ... infile[nf] onto outfile } procedure merge (var infile : fdbuf; nf : integer; outfile : filedesc); var i, j : integer; lbp : charpos; temp : string; #include "reheap.p" #include "sccopy.p" #include "cscopy.p" begin j := 0; for i := 1 to nf do { get one line from each file } if (getline(temp, infile[i], MAXSTR)) then begin lbp := (i-1)*MAXSTR + 1; { room for longest } sccopy(temp, linebuf, lbp); linepos[i] := lbp; j := j + 1 end; nf := j; quick(linepos, nf, linebuf); { make initial heap } while (nf > 0) do begin lbp := linepos[1]; { lowest line } cscopy(linebuf, lbp, temp); putstr(temp, outfile); i := lbp div MAXSTR + 1; { compute file index } if (getline(temp, infile[i], MAXSTR)) then sccopy(temp, linebuf, lbp) else begin { one less input file } linepos[1] := linepos[nf]; nf := nf - 1 end; reheap(linepos, nf, linebuf) end end; -h- SORT/ptext.p 397 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { ptext -- output text lines from linebuf } procedure ptext (var linepos : posbuf; nlines : integer; var linebuf : charbuf; outfile : filedesc); var i, j : integer; begin for i := 1 to nlines do begin j := linepos[i]; while (linebuf[j] <> ENDSTR) do begin putcf(linebuf[j], outfile); j := j + 1 end end end; -h- SORT/putrot.p 439 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putrot -- create lines with keyword at front } procedure putrot (var buf : string); var i : integer; #include "rotate.p" begin i := 1; while (buf[i] <> NEWLINE) and (buf[i] <> ENDSTR) do begin if (isalphanum(buf[i])) then begin rotate(buf, i); { token starts at "i" } repeat i := i + 1 until (not isalphanum(buf[i])) end; i := i + 1 end end; -h- SORT/quick.p 234 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { quick -- quicksort for lines } procedure quick (var linepos : posbuf; nlines : pos; var linebuf : charbuf); #include "rquick.p" begin rquick(1, nlines) end; -h- SORT/reheap.p 594 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { reheap -- put linebuf[linepos[1]] in proper place in heap } procedure reheap (var linepos : posbuf; nf : pos; var linebuf : charbuf); var i, j : integer; begin i := 1; j := 2 * i; while (j <= nf) do begin if (j < nf) then { find smaller child } if (cmp(linepos[j],linepos[j+1],linebuf)>0) then j := j + 1; if (cmp(linepos[i], linepos[j], linebuf)<=0) then i := nf { proper position found; terminate loop } else exchange(linepos[i], linepos[j]); { percolate } i := j; j := 2 * i end end; -h- SORT/rotate.p 354 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { rotate -- output rotated line } procedure rotate (var buf : string; n : integer); var i : integer; begin i := n; while (buf[i] <> NEWLINE) and (buf[i] <> ENDSTR) do begin putc(buf[i]); i := i + 1 end; putc(FOLD); for i := 1 to n-1 do putc(buf[i]); putc(NEWLINE) end; -h- SORT/rquick.p 754 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { rquick -- recursive quicksort } procedure rquick (lo, hi: integer); var i, j : integer; pivline : charpos; begin if (lo < hi) then begin i := lo; j := hi; pivline := linepos[j]; { pivot line } repeat while (i < j) and (cmp(linepos[i],pivline,linebuf) <= 0) do i := i + 1; while (j > i) and (cmp(linepos[j],pivline,linebuf) >= 0) do j := j - 1; if (i < j) then { out of order pair } exchange(linepos[i], linepos[j]) until (i >= j); exchange(linepos[i], linepos[hi]); { move pivot to i } if (i - lo < hi - i) then begin rquick(lo, i-1); rquick(i+1, hi) end else begin rquick(i+1, hi); rquick(lo, i-1) end end end; -h- SORT/sccopy.p 318 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { sccopy -- copy string s to cb[i]... } procedure sccopy (var s : string; var cb : charbuf; i : charpos); var j : integer; begin j := 1; while (s[j] <> ENDSTR) do begin cb[i] := s[j]; j := j + 1; i := i + 1 end; cb[i] := ENDSTR end; -h- SORT/shell.p 621 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { shell -- ascending Shell sort for lines } procedure shell (var linepos : posbuf; nlines : integer; var linebuf : charbuf); var gap, i, j, jg : integer; #include "cmp.p" #include "exchange.p" begin gap := nlines div 2; while (gap > 0) do begin for i := gap+1 to nlines do begin j := i - gap; while (j > 0) do begin jg := j + gap; if (cmp(linepos[j],linepos[jg],linebuf)<=0) then j := 0 { force loop termination } else exchange(linepos[j], linepos[jg]); j := j - gap end end; gap := gap div 2 end end; -h- SORT/shell0.p 572 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { shell -- Shell sort v[1]...v[n] increasing } procedure shell (var v : intarray; n : integer); var gap, i, j, jg, k : integer; begin gap := n div 2; while (gap > 0) do begin for i := gap+1 to n do begin j := i - gap; while (j > 0) do begin jg := j + gap; if (v[j] <= v[jg]) then { compare } j := 0 { force loop termination } else begin k := v[j]; { exchange } v[j] := v[jg]; v[jg] := k end; j := j - gap end end; gap := gap div 2 end end; -h- SORT/sort.p 1284 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { sort -- external sort of text lines } procedure sort; const MAXCHARS = 10000; { maximum # of text characters } MAXLINES = 300; { maximum # of lines } MERGEORDER = 5; type charpos = 1..MAXCHARS; charbuf = array [1..MAXCHARS] of character; posbuf = array [1..MAXLINES] of charpos; pos = 0..MAXLINES; fdbuf = array [1..MERGEORDER] of filedesc; var linebuf : charbuf; linepos : posbuf; nlines : pos; infile : fdbuf; outfile : filedesc; high, low, lim : integer; done : boolean; name : string; #include "sortproc.p" begin high := 0; repeat { initial formation of runs } done := gtext(linepos, nlines, linebuf, STDIN); quick(linepos, nlines, linebuf); high := high + 1; outfile := makefile(high); ptext(linepos, nlines, linebuf, outfile); close(outfile) until (done); low := 1; while (low < high) do begin { merge runs } lim := min(low+MERGEORDER-1, high); gopen(infile, low, lim); high := high + 1; outfile := makefile(high); merge(infile, lim-low+1, outfile); close(outfile); gremove(infile, low, lim); low := low + MERGEORDER end; gname(high, name); { final cleanup } outfile := open(name, IOREAD); fcopy(outfile, STDOUT); close(outfile); remove(name) end; -h- SORT/sortproc.p 304 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { sortproc -- procedures for sort } #include "cmp.p" #include "exchange.p" #include "gtext.p" #include "ptext.p" #include "quick.p" #include "gname.p" #include "makefile.p" #include "gopen.p" #include "merge.p" #include "gremove.p" -h- SORT/sortquick.p 690 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { sort -- sort text lines in memory } procedure sort; const MAXCHARS = 1000; { maximum number of text characters } MAXLINES = 100; { maximum number of line pointers } type charpos = 1..MAXCHARS; charbuf = array [1..MAXCHARS] of character; posbuf = array [1..MAXLINES] of charpos; pos = 0..MAXLINES; var linbuf : charbuf; linpos : posbuf; nlines : pos; #include "gtext.p" #include "quick.p" #include "ptext.p" begin if (gtext(linpos, nlines, linbuf, STDIN) = ENDFILE) then begin quick(linpos, nlines, linbuf); ptext(linpos, nlines, linbuf, STDOUT) end else error('sort: input too big to sort') end; -h- SORT/sorttest.p 424 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } procedure sorttest; type intarray = array [1..100] of integer; var v : intarray; buf : string; i, j : integer; #include "shell0.p" #include "ctoi.p" begin j := 0; while (getline(buf, STDIN, MAXSTR)) do begin j := j + 1; i := 1; v[j] := ctoi(buf, i) end; shell(v, j); for i := 1 to j do begin putdec(v[i], 1); putc(NEWLINE) end end; -h- SORT/unique.p 380 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { unique -- remove adjacent duplicate lines } procedure unique; var buf : array [0..1] of string; cur : 0..1; begin cur := 1; buf[1-cur][1] := ENDSTR; while (getline(buf[cur], STDIN, MAXSTR)) do if (not equal(buf[cur], buf[1-cur])) then begin putstr(buf[cur], STDOUT); cur := 1 - cur end end; -h- SORT/unrotate.p 783 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { unrotate -- unrotate lines rotated by kwic } procedure unrotate; const MAXOUT = 80; MIDDLE = 40; FOLD = DOLLAR; var inbuf, outbuf : string; i, j, f : integer; begin while (getline(inbuf, STDIN, MAXSTR)) do begin for i := 1 to MAXOUT-1 do outbuf[i] := BLANK; f := index(inbuf, FOLD); j := MIDDLE - 1; for i := length(inbuf)-1 downto f+1 do begin outbuf[j] := inbuf[i]; j := j - 1; if (j <= 0) then j := MAXOUT - 1 end; j := MIDDLE + 1; for i := 1 to f-1 do begin outbuf[j] := inbuf[i]; j := j mod (MAXOUT-1) + 1 end; for j := 1 to MAXOUT-1 do if (outbuf[j] <> BLANK) then i := j; outbuf[i+1] := ENDSTR; putstr(outbuf, STDOUT); putc(NEWLINE) end end; -h- EDIT/altpatsize.p 472 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { patsize -- returns size of pattern entry at pat[n] } function patsize (var pat : string; n : integer) : integer; begin if (pat[n] = LITCHAR) then patsize := 2 else if (pat[n] in [BOL, EOL, ANY]) then patsize := 1 else if (pat[n] = CCL) or (pat[n] = NCCL) then patsize := pat[n+1] + 2 else if (pat[n] = CLOSURE) then patsize := CLOSIZE else error('in patsize: can''t happen') end; -h- EDIT/amatch.p 1265 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { amatch -- look for match of pat[j]... at lin[offset]... } function amatch (var lin : string; offset : integer; var pat : string; j : integer) : integer; var i, k : integer; done : boolean; #include "omatch.p" #include "patsize.p" begin done := false; while (not done) and (pat[j] <> ENDSTR) do if (pat[j] = CLOSURE) then begin j := j + patsize(pat, j); { step over CLOSURE } i := offset; { match as many as possible } while (not done) and (lin[i] <> ENDSTR) do if (not omatch(lin, i, pat, j)) then done := true; { i points to input character that made us fail } { match rest of pattern against rest of input } { shrink closure by 1 after each failure } done := false; while (not done) and (i >= offset) do begin k := amatch(lin, i, pat, j+patsize(pat,j)); if (k > 0) then { matched rest of pattern } done := true else i := i - 1 end; offset := k; { if k = 0 failure else success } done := true end else if (not omatch(lin, offset, pat, j)) then begin offset := 0; { non-closure } done := true end else { omatch succeeded on this pattern element } j := j + patsize(pat, j); amatch := offset end; -h- EDIT/amatch0.p 367 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { amatch -- with no metacharacters } function amatch (var lin : string; i : integer; var pat : string; j : integer) : integer; begin while (pat[j] <> ENDSTR) and (i > 0) do if (lin[i] <> pat[j]) then i := 0 { no match } else begin i := i + 1; j := j + 1 end; amatch := i end; -h- EDIT/amatch1.p 392 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { amatch -- with some metacharacters } function amatch (var lin : string; i : integer; var pat : string; j : integer) : integer; #include "omatch.p" begin while (pat[j] <> ENDSTR) and (i > 0) do if (omatch(lin, i, pat, j)) then j := j + patsize(pat, j) else i := 0; { no match possible } amatch := i end; -h- EDIT/append.p 599 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { append -- append lines after "line" } function append (line : integer; glob : boolean) : stcode; var inline : string; stat : stcode; done : boolean; begin if (glob) then stat := ERR else begin curln := line; stat := OK; done := false; while (not done) and (stat = OK) do if (not getline(inline, STDIN, MAXSTR)) then stat := ENDDATA else if (inline[1] = PERIOD) and (inline[2] = NEWLINE) then done := true else if (puttxt(inline) = ERR) then stat := ERR end; append := stat end; -h- EDIT/blkmove.p 366 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { blkmove -- move block of lines n1..n2 to after n3 } procedure blkmove (n1, n2, n3 : integer); begin if (n3 < n1-1) then begin reverse(n3+1, n1-1); reverse(n1, n2); reverse(n3+1, n2) end else if (n3 > n2) then begin reverse(n1, n2); reverse(n2+1, n3); reverse(n1, n3) end end; -h- EDIT/catsub.p 510 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { catsub -- add replacement text to end of new } procedure catsub (var lin : string; s1, s2 : integer; var sub : string; var new : string; var k : integer; maxnew : integer); var i, j : integer; junk : boolean; begin i := 1; while (sub[i] <> ENDSTR) do begin if (sub[i] = DITTO) then for j := s1 to s2-1 do junk := addstr(lin[j], new, k, maxnew) else junk := addstr(sub[i], new, k, maxnew); i := i + 1 end end; -h- EDIT/change.p 630 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { change -- change "from" into "to" on each line } procedure change; #include "findcons.p" DITTO = -1; var lin, pat, sub, arg : string; #include "getpat.p" #include "getsub.p" #include "subline.p" begin if (not getarg(1, arg, MAXSTR)) then error('usage: change from [to]'); if (not getpat(arg, pat)) then error('change: illegal "from" pattern'); if (not getarg(2, arg, MAXSTR)) then arg[1] := ENDSTR; if (not getsub(arg, sub)) then error('change: illegal "to" string'); while (getline(lin, STDIN, MAXSTR)) do subline(lin, pat, sub) end; -h- EDIT/chngcons.p 194 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { chngcons.p -- const declarations for change } #include "findcons.p" DITTO = 1; { risky to store binary value in char } -h- EDIT/chngproc.p 190 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { chngproc -- procedures for change } #include "getpat.p" #include "getsub.p" #include "amatch.p" #include "catsub.p" -h- EDIT/ckglob.p 827 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { ckglob -- if global prefix, mark lines to be affected } function ckglob (var lin : string; var i : integer; var status : stcode) : stcode; var n : integer; gflag : boolean; temp : string; begin if (lin[i] <> GCMD) and (lin[i] <> XCMD) then status := ENDDATA else begin gflag := (lin[i] = GCMD); i := i + 1; if (optpat(lin, i) = ERR) then status := ERR else if (default(1,lastln,status) <> ERR) then begin i := i + 1; { mark affected lines } for n := line1 to line2 do begin gettxt(n, temp); putmark(n, (match(temp, pat) = gflag)) end; for n := 1 to line1-1 do { erase other marks } putmark(n, false); for n := line2+1 to lastln do putmark(n, false); status := OK end end; ckglob := status end; -h- EDIT/ckp.p 411 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { ckp -- check for "p" after command } function ckp (var lin : string; i : integer; var pflag : boolean; var status : stcode) : stcode; begin skipbl(lin, i); if (lin[i] = PCMD) then begin i := i + 1; pflag := true end else pflag := false; if (lin[i] = NEWLINE) then status := OK else status := ERR; ckp := status end; -h- EDIT/clrbuf1.p 170 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { clrbuf (in memory) -- initialize for new file } procedure clrbuf; begin { nothing to do } end; -h- EDIT/clrbuf2.p 203 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { clrbuf (scratch file) -- dispose of scratch file } procedure clrbuf; begin close(scrin); close(scrout); remove(edittemp) end; -h- EDIT/default.p 363 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { default -- set defaulted line numbers } function default (def1, def2 : integer; var status : stcode) : stcode; begin if (nlines = 0) then begin line1 := def1; line2 := def2 end; if (line1 > line2) or (line1 <= 0) then status := ERR else status := OK; default := status end; -h- EDIT/docmd.p 2981 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { docmd -- handle all commands except globals } function docmd (var lin : string; var i : integer; glob : boolean; var status : stcode) : stcode; var fil, sub : string; line3 : integer; gflag, pflag : boolean; begin pflag := false; { may be set by d, m, s } status := ERR; if (lin[i] = PCMD) then begin if (lin[i+1] = NEWLINE) then if (default(curln, curln, status) = OK) then status := doprint(line1, line2) end else if (lin[i] = NEWLINE) then begin if (nlines = 0) then line2 := nextln(curln); status := doprint(line2, line2) end else if (lin[i] = QCMD) then begin if (lin[i+1]=NEWLINE) and (nlines=0) and (not glob) then status := ENDDATA end else if (lin[i] = ACMD) then begin if (lin[i+1] = NEWLINE) then status := append(line2, glob) end else if (lin[i] = CCMD) then begin if (lin[i+1] = NEWLINE) then if (default(curln, curln, status) = OK) then if (lndelete(line1, line2, status) = OK) then status := append(prevln(line1), glob) end else if (lin[i] = DCMD) then begin if (ckp(lin, i+1, pflag, status) = OK) then if (default(curln, curln, status) = OK) then if (lndelete(line1, line2, status) = OK) then if (nextln(curln) <> 0) then curln := nextln(curln) end else if (lin[i] = ICMD) then begin if (lin[i+1] = NEWLINE) then begin if (line2 = 0) then status := append(0, glob) else status := append(prevln(line2), glob) end end else if (lin[i] = EQCMD) then begin if (ckp(lin, i+1, pflag, status) = OK) then begin putdec(line2, 1); putc(NEWLINE) end end else if (lin[i] = MCMD) then begin i := i + 1; if (getone(lin, i, line3, status) = ENDDATA) then status := ERR; if (status = OK) then if (ckp(lin, i, pflag, status) = OK) then if (default(curln, curln, status) = OK) then status := move(line3) end else if (lin[i] = SCMD) then begin i := i + 1; if (optpat(lin, i) = OK) then if (getrhs(lin, i, sub, gflag) = OK) then if (ckp(lin, i+1, pflag, status) = OK) then if (default(curln, curln, status) = OK) then status := subst(sub, gflag, glob) end else if (lin[i] = ECMD) then begin if (nlines = 0) then if (getfn(lin, i, fil) = OK) then begin scopy(fil, 1, savefile, 1); clrbuf; setbuf; status := doread(0, fil) end end else if (lin[i] = FCMD) then begin if (nlines = 0) then if (getfn(lin, i, fil) = OK) then begin scopy(fil, 1, savefile, 1); putstr(savefile, STDOUT); putc(NEWLINE); status := OK end end else if (lin[i] = RCMD) then begin if (getfn(lin, i, fil) = OK) then status := doread(line2, fil) end else if (lin[i] = WCMD) then begin if (getfn(lin, i, fil) = OK) then if (default(1, lastln, status) = OK) then status := dowrite(line1, line2, fil) end; { else status is ERR } if (status = OK) and (pflag) then status := doprint(curln, curln); docmd := status end; -h- EDIT/dodash.p 891 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dodash - expand set at src[i] into dest[j], stop at delim } procedure dodash (delim : character; var src : string; var i : integer; var dest : string; var j : integer; maxset : integer); var k : integer; junk : boolean; begin while (src[i] <> delim) and (src[i] <> ENDSTR) do begin if (src[i] = ESCAPE) then junk := addstr(esc(src, i), dest, j, maxset) else if (src[i] <> DASH) then junk := addstr(src[i], dest, j, maxset) else if (j <= 1) or (src[i+1] = ENDSTR) then junk := addstr(DASH,dest,j,maxset) { literal - } else if (isalphanum(src[i-1])) and (isalphanum(src[i+1])) and (src[i-1] <= src[i+1]) then begin for k := src[i-1]+1 to src[i+1] do junk := addstr(k, dest, j, maxset); i := i + 1 end else junk := addstr(DASH, dest, j, maxset); i := i + 1 end end; -h- EDIT/doglob.p 664 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { doglob -- do command at lin[i] on all marked lines } function doglob (var lin : string; var i, cursave : integer; var status : stcode) : stcode; var count, istart, n : integer; begin status := OK; count := 0; n := line1; istart := i; repeat if (getmark(n)) then begin putmark(n, false); curln := n; cursave := curln; i := istart; if (getlist(lin, i, status) = OK) then if (docmd(lin, i, true, status) = OK) then count := 0 end else begin n := nextln(n); count := count + 1 end until (count > lastln) or (status <> OK); doglob := status end; -h- EDIT/doprint.p 369 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { doprint -- print lines n1 through n2 } function doprint (n1, n2 : integer) : stcode; var i : integer; line : string; begin if (n1 <= 0) then doprint := ERR else begin for i := n1 to n2 do begin gettxt(i, line); putstr(line, STDOUT) end; curln := n2; doprint := OK end end; -h- EDIT/doread.p 645 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { doread -- read "fil" after line n } function doread (n : integer; var fil : string) : stcode; var count : integer; t : boolean; stat : stcode; fd : filedesc; inline : string; begin fd := open(fil, IOREAD); if (fd = IOERROR) then stat := ERR else begin curln := n; stat := OK; count := 0; repeat t := getline(inline, fd, MAXSTR); if (t) then begin stat := puttxt(inline); if (stat <> ERR) then count := count + 1 end until (stat <> OK) or (t = false); close(fd); putdec(count, 1); putc(NEWLINE) end; doread := stat end; -h- EDIT/dowrite.p 473 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dowrite -- write lines n1..n2 into file } function dowrite (n1, n2 : integer; var fil : string) : stcode; var i : integer; fd : filedesc; line : string; begin fd := create(fil, IOWRITE); if (fd = IOERROR) then dowrite := ERR else begin for i := n1 to n2 do begin gettxt(i, line); putstr(line, fd) end; close(fd); putdec(n2-n1+1, 1); putc(NEWLINE); dowrite := OK end end; -h- EDIT/edit.p 994 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { edit -- main routine for text editor } procedure edit; #include "editcons.p" #include "edittype.p" #include "editvar.p" cursave, i : integer; status : stcode; more : boolean; #include "editproc.p" begin setbuf; pat[1] := ENDSTR; savefile[1] := ENDSTR; if (getarg(1, savefile, MAXSTR)) then if (doread(0, savefile) = ERR) then message('?'); more := getline(lin, STDIN, MAXSTR); while (more) do begin i := 1; cursave := curln; if (getlist(lin, i, status) = OK) then begin if (ckglob(lin, i, status) = OK) then status := doglob(lin, i, cursave, status) else if (status <> ERR) then status := docmd(lin, i, false, status) { else ERR, do nothing } end; if (status = ERR) then begin message('?'); curln := min(cursave, lastln) end else if (status = ENDDATA) then more := false; { else OK } if (more) then more := getline(lin, STDIN, MAXSTR) end; clrbuf end; -h- EDIT/editcons.p 695 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { editcons -- const declarations for edit } const MAXLINES = 100; { set small for testing } MAXPAT = MAXSTR; CLOSIZE = 1; { size of a closure entry } DITTO = -1; CLOSURE = STAR; BOL = PERCENT; EOL = DOLLAR; ANY = QUESTION; CCL = LBRACK; CCLEND = RBRACK; NEGATE = CARET; NCCL = EXCLAM; LITCHAR = LETC; CURLINE = PERIOD; LASTLINE = DOLLAR; SCAN = SLASH; BACKSCAN = BACKSLASH; ACMD = LETA; { = ord('a') } CCMD = LETC; DCMD = LETD; ECMD = LETE; EQCMD = EQUALS; FCMD = LETF; GCMD = LETG; ICMD = LETI; MCMD = LETM; PCMD = LETP; QCMD = LETQ; RCMD = LETR; SCMD = LETS; WCMD = LETW; XCMD = LETX; -h- EDIT/editproc.p 676 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { editproc -- procedures for edit } #include "edprim.p" { editor buffer primitives } #include "amatch.p" #include "match.p" #include "skipbl.p" #include "optpat.p" #include "nextln.p" #include "prevln.p" #include "patscan.p" #include "getnum.p" #include "getone.p" #include "getlist.p" #include "append.p" #include "lndelete.p" #include "doprint.p" #include "doread.p" #include "dowrite.p" #include "move.p" #include "makesub.p" #include "getrhs.p" #include "catsub.p" #include "subst.p" #include "ckp.p" #include "default.p" #include "getfn.p" #include "docmd.p" #include "ckglob.p" #include "doglob.p" -h- EDIT/edittype.p 93 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } #include "edtype2.p" -h- EDIT/editvar.p 92 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } #include "edvar2.p" -h- EDIT/edprim.p 93 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } #include "edprim2.p" -h- EDIT/edprim1.p 240 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } #include "setbuf1.p" #include "clrbuf1.p" #include "getmark.p" #include "putmark.p" #include "gettxt1.p" #include "reverse.p" #include "blkmove.p" #include "puttxt1.p" -h- EDIT/edprim2.p 258 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } #include "seek.p" #include "setbuf2.p" #include "clrbuf2.p" #include "getmark.p" #include "putmark.p" #include "gettxt2.p" #include "reverse.p" #include "blkmove.p" #include "puttxt2.p" -h- EDIT/edtype1.p 307 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { edittype -- types for in-memory version of edit } type stcode = (ENDDATA, ERR, OK); { status returns } buftype = { in-memory edit buffer entry } record txt : string; { text of line } mark : boolean { mark for line } end; -h- EDIT/edtype2.p 260 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { edittype -- types for scratch-file version of edit } type stcode = (ENDDATA, ERR, OK); buftype = record txt : integer; { text of line } mark : boolean { mark for line } end; -h- EDIT/edvar1.p 485 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { editvar -- variables for edit } var buf : array [0..MAXLINES] of buftype; line1 : integer; { first line number } line2 : integer; { second line number } nlines : integer; { # of line numbers specified } curln : integer; { current line -- value of dot } lastln : integer; { last line -- value of $ } pat : string; { pattern } lin : string; { input line } savefile : string; { remembered file name } -h- EDIT/edvar2.p 722 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { editvar -- variables for edit } var buf : array [0..MAXLINES] of buftype; scrout : filedesc; { scratch input fd } scrin : filedesc; { scratch output fd } recin : integer; { next record to read from scrin } recout : integer; { next record to write on scrout } edittemp : string; { temp file name 'edtemp' } line1 : integer; { first line number } line2 : integer; { second line number } nlines : integer; { # of line numbers specified } curln : integer; { current line -- value of dot } lastln : integer; { last line -- value of $ } pat : string; { pattern } lin : string; { input line } savefile : string; { remembered file name } -h- EDIT/find.p 454 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { find -- find patterns in text } procedure find; #include "findcons.p" var arg, lin, pat : string; #include "getpat.p" #include "match.p" begin if (not getarg(1, arg, MAXSTR)) then error('usage: find pattern'); if (not getpat(arg, pat)) then error('find: illegal pattern'); while (getline(lin, STDIN, MAXSTR)) do if (match(lin, pat)) then putstr(lin, STDOUT) end; -h- EDIT/findcons.p 378 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { findcons -- const declarations for find } const MAXPAT = MAXSTR; CLOSIZE = 1; { size of a closure entry } CLOSURE = STAR; BOL = PERCENT; EOL = DOLLAR; ANY = QUESTION; CCL = LBRACK; CCLEND = RBRACK; NEGATE = CARET; NCCL = EXCLAM; { cannot be the same as NEGATE } LITCHAR = LETC; { ord('c') } -h- EDIT/getccl.p 636 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getccl -- expand char class at arg[i] into pat[j] } function getccl (var arg : string; var i : integer; var pat : string; var j : integer) : boolean; var jstart : integer; junk : boolean; #include "dodash.p" begin i := i + 1; { skip over '[' } if (arg[i] = NEGATE) then begin junk := addstr(NCCL, pat, j, MAXPAT); i := i + 1 end else junk := addstr(CCL, pat, j, MAXPAT); jstart := j; junk := addstr(0, pat, j, MAXPAT); { room for count } dodash(CCLEND, arg, i, pat, j, MAXPAT); pat[jstart] := j - jstart - 1; getccl := (arg[i] = CCLEND) end; -h- EDIT/getfn.p 668 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getfn -- get file name from lin[i]... } function getfn (var lin : string; var i : integer; var fil : string) : stcode; var k : integer; stat : stcode; #include "getword.p" begin stat := ERR; if (lin[i+1] = BLANK) then begin k := getword(lin, i+2, fil); { get new filename } if (k > 0) then if (lin[k] = NEWLINE) then stat := OK end else if (lin[i+1] = NEWLINE) and (savefile[1] <> ENDSTR) then begin scopy(savefile, 1, fil, 1); stat := OK end; if (stat = OK) and (savefile[1] = ENDSTR) then scopy(fil, 1, savefile, 1); { save if no old one } getfn := stat end; -h- EDIT/getlist.p 793 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getlist -- get list of line nums at lin[i], increment i } function getlist (var lin : string; var i : integer; var status : stcode) : stcode; var num : integer; done : boolean; begin line2 := 0; nlines := 0; done := (getone(lin, i, num, status) <> OK); while (not done) do begin line1 := line2; line2 := num; nlines := nlines + 1; if (lin[i] = SEMICOL) then curln := num; if (lin[i] = COMMA) or (lin[i] = SEMICOL) then begin i := i + 1; done := (getone(lin, i, num, status) <> OK) end else done := true end; nlines := min(nlines, 2); if (nlines = 0) then line2 := curln; if (nlines <= 1) then line1 := line2; if (status <> ERR) then status := OK; getlist := status end; -h- EDIT/getmark.p 187 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getmark -- get mark from nth line } function getmark (n : integer) : boolean; begin getmark := buf[n].mark end; -h- EDIT/getnum.p 755 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getnum -- get single line number component } function getnum (var lin : string; var i, num : integer; var status : stcode) : stcode; begin status := OK; skipbl(lin, i); if (isdigit(lin[i])) then begin num := ctoi(lin, i); i := i - 1 { move back; to be advanced at end } end else if (lin[i] = CURLINE) then num := curln else if (lin[i] = LASTLINE) then num := lastln else if (lin[i] = SCAN) or (lin[i] = BACKSCAN) then begin if (optpat(lin, i) = ERR) then { build pattern } status := ERR else status := patscan(lin[i], num) end else status := ENDDATA; if (status = OK) then i := i + 1; { next character to be examined } getnum := status end; -h- EDIT/getone.p 891 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getone -- get one line number expression } function getone (var lin : string; var i, num : integer; var status : stcode) : stcode; var istart, mul, pnum : integer; begin istart := i; num := 0; if (getnum(lin, i, num, status) = OK) then { 1st term } repeat { + or - terms } skipbl(lin, i); if (lin[i] <> PLUS) and (lin[i] <> MINUS) then status := ENDDATA else begin if (lin[i] = PLUS) then mul := +1 else mul := -1; i := i + 1; if (getnum(lin, i, pnum, status) = OK) then num := num + mul * pnum; if (status = ENDDATA) then status := ERR end until (status <> OK); if (num < 0) or (num > lastln) then status := ERR; if (status <> ERR) then begin if (i <= istart) then status := ENDDATA else status := OK end; getone := status end; -h- EDIT/getpat.p 245 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getpat -- convert argument into pattern } function getpat (var arg, pat : string) : boolean; #include "makepat.p" begin getpat := (makepat(arg, 1, ENDSTR, pat) > 0) end; -h- EDIT/getrhs.p 544 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getrhs -- get right hand side of "s" command } function getrhs (var lin : string; var i : integer; var sub : string; var gflag : boolean) : stcode; begin getrhs := OK; if (lin[i] = ENDSTR) then getrhs := ERR else if (lin[i+1] = ENDSTR) then getrhs := ERR else begin i := makesub(lin, i+1, lin[i], sub); if (i = 0) then getrhs := ERR else if (lin[i+1] = ord('g')) then begin i := i + 1; gflag := true end else gflag := false end end; -h- EDIT/getsub.p 248 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getsub -- get substitution string into sub } function getsub (var arg, sub : string) : boolean; #include "makesub.p" begin getsub := (makesub(arg, 1, ENDSTR, sub) > 0) end; -h- EDIT/gettxt1.p 213 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gettxt (in memory) -- get text from line n into s } procedure gettxt (n : integer; var s : string); begin scopy(buf[n].txt, 1, s, 1) end; -h- EDIT/gettxt2.p 345 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gettxt (scratch file) -- get text from line n into s } procedure gettxt (n : integer; var s : string); var junk : boolean; begin if (n = 0) then s[1] := ENDSTR else begin seek(buf[n].txt, scrin); recin := recin + 1; junk := getline(s, scrin, MAXSTR) end end; -h- EDIT/getword.p 478 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getword -- get word from s[i] into out } function getword (var s : string; i : integer; var out : string) : integer; var j : integer; begin while (s[i] in [BLANK, TAB, NEWLINE]) do i := i + 1; j := 1; while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin out[j] := s[i]; i := i + 1; j := j + 1 end; out[j] := ENDSTR; if (s[i] = ENDSTR) then getword := 0 else getword := i end; -h- EDIT/lndelete.p 371 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { lndelete -- delete lines n1 through n2 } function lndelete (n1, n2 : integer; var status : stcode) : stcode; begin if (n1 <= 0) then status := ERR else begin blkmove(n1, n2, lastln); lastln := lastln - (n2 - n1 + 1); curln := prevln(n1); status := OK end; lndelete := status end; -h- EDIT/locate.p 502 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { locate -- look for c in character class at pat[offset] } function locate (c : character; var pat : string; offset : integer) : boolean; var i : integer; begin { size of class is at pat[offset], characters follow } locate := false; i := offset + pat[offset]; { last position } while (i > offset) do if (c = pat[i]) then begin locate := true; i := offset { force loop termination } end else i := i - 1 end; -h- EDIT/makepat.p 1385 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { makepat -- make pattern from arg[i], terminate at delim } function makepat (var arg : string; start : integer; delim : character; var pat : string) : integer; var i, j, lastj, lj : integer; done, junk : boolean; #include "getccl.p" #include "stclose.p" begin j := 1; { pat index } i := start; { arg index } lastj := 1; done := false; while (not done) and (arg[i] <> delim) and (arg[i] <> ENDSTR) do begin lj := j; if (arg[i] = ANY) then junk := addstr(ANY, pat, j, MAXPAT) else if (arg[i] = BOL) and (i = start) then junk := addstr(BOL, pat, j, MAXPAT) else if (arg[i] = EOL) and (arg[i+1] = delim) then junk := addstr(EOL, pat, j, MAXPAT) else if (arg[i] = CCL) then done := (getccl(arg, i, pat, j) = false) else if (arg[i] = CLOSURE) and (i > start) then begin lj := lastj; if (pat[lj] in [BOL, EOL, CLOSURE]) then done := true { force loop termination } else stclose(pat, j, lastj) end else begin junk := addstr(LITCHAR, pat, j, MAXPAT); junk := addstr(esc(arg, i), pat, j, MAXPAT) end; lastj := lj; if (not done) then i := i + 1 end; if (done) or (arg[i] <> delim) then { finished early } makepat := 0 else if (not addstr(ENDSTR, pat, j, MAXPAT)) then makepat := 0 { no room } else makepat := i { all is well } end; -h- EDIT/makesub.p 657 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { makesub -- make substitution string from arg in sub } function makesub (var arg : string; from : integer; delim : character; var sub : string) : integer; var i, j : integer; junk : boolean; begin j := 1; i := from; while (arg[i] <> delim) and (arg[i] <> ENDSTR) do begin if (arg[i] = ord('&')) then junk := addstr(DITTO, sub, j, MAXPAT) else junk := addstr(esc(arg, i), sub, j, MAXPAT); i := i + 1 end; if (arg[i] <> delim) then { missing delimiter } makesub := 0 else if (not addstr(ENDSTR, sub, j, MAXPAT)) then makesub := 0 else makesub := i end; -h- EDIT/match.p 358 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { match -- find match anywhere on line } function match (var lin, pat : string) : boolean; var i, pos : integer; #include "amatch.p" begin pos := 0; i := 1; while (lin[i] <> ENDSTR) and (pos = 0) do begin pos := amatch(lin, i, pat, 1); i := i + 1 end; match := (pos > 0) end; -h- EDIT/move.p 401 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { move -- move line1 through line2 after line3 } function move (line3 : integer) : stcode; begin if (line1<=0) or ((line3>=line1) and (line3 line1) then curln := line3 else curln := line3 + (line2 - line1 + 1); move := OK end end; -h- EDIT/nextln.p 217 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { nextln -- get line after n } function nextln (n : integer) : integer; begin if (n >= lastln) then nextln := 0 else nextln := n + 1 end; -h- EDIT/omatch.p 977 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { omatch -- match one pattern element at pat[j] } function omatch (var lin : string; var i : integer; var pat : string; j : integer) : boolean; var advance : -1..1; #include "locate.p" begin advance := -1; if (lin[i] = ENDSTR) then omatch := false else if (not (pat[j] in [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then error('in omatch: can''t happen') else case pat[j] of LITCHAR: if (lin[i] = pat[j+1]) then advance := 1; BOL: if (i = 1) then advance := 0; ANY: if (lin[i] <> NEWLINE) then advance := 1; EOL: if (lin[i] = NEWLINE) then advance := 0; CCL: if (locate(lin[i], pat, j+1)) then advance := 1; NCCL: if (lin[i] <> NEWLINE) and (not locate(lin[i], pat, j+1)) then advance := 1 end; if (advance >= 0) then begin i := i + advance; omatch := true end else omatch := false end; -h- EDIT/optpat.p 579 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { optpat -- get optional pattern from lin[i], increment i } function optpat (var lin : string; var i : integer) : stcode; #include "makepat.p" begin if (lin[i] = ENDSTR) then i := 0 else if (lin[i+1] = ENDSTR) then i := 0 else if (lin[i+1] = lin[i]) then { repeated delimiter } i := i + 1 { leave existing pattern alone } else i := makepat(lin, i+1, lin[i], pat); if (pat[1] = ENDSTR) then i := 0; if (i = 0) then begin pat[1] := ENDSTR; optpat := ERR end else optpat := OK end; -h- EDIT/patscan.p 487 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { patscan -- find next occurrence of pattern after line n } function patscan (way : character; var n : integer) : stcode; var done : boolean; line : string; begin n := curln; patscan := ERR; done := false; repeat if (way = SCAN) then n := nextln(n) else n := prevln(n); gettxt(n, line); if (match(line, pat)) then begin patscan := OK; done := true end until (n = curln) or (done) end; -h- EDIT/patsize.p 483 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { patsize -- returns size of pattern entry at pat[n] } function patsize (var pat : string; n : integer) : integer; begin if (not (pat[n] in [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then error('in patsize: can''t happen') else case pat[n] of LITCHAR: patsize := 2; BOL, EOL, ANY: patsize := 1; CCL, NCCL: patsize := pat[n+1] + 2; CLOSURE: patsize := CLOSIZE end end; -h- EDIT/prevln.p 217 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { prevln -- get line before n } function prevln (n : integer) : integer; begin if (n <= 0) then prevln := lastln else prevln := n - 1 end; -h- EDIT/putmark.p 184 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putmark -- put mark m on nth line } procedure putmark(n : integer; m : boolean); begin buf[n].mark := m end; -h- EDIT/putsub.p 393 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putsub -- output substitution text } procedure putsub