-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 (var lin : string; s1, s2 : integer; var sub : string); 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 putc(lin[j]) else putc(sub[i]); i := i + 1 end end; -h- EDIT/puttxt1.p 398 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { puttxt (in memory) -- put text from lin after curln } function puttxt (var lin : string) : stcode; begin puttxt := ERR; if (lastln < MAXLINES) then begin lastln := lastln + 1; scopy(lin, 1, buf[lastln].txt, 1); putmark(lastln, false); blkmove(lastln, lastln, curln); curln := curln + 1; puttxt := OK end end; -h- EDIT/puttxt2.p 440 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { puttxt (scratch file) -- put text from lin after curln } function puttxt (var lin : string) : stcode; begin puttxt := ERR; if (lastln < MAXLINES) then begin lastln := lastln + 1; putstr(lin, scrout); putmark(lastln, false); buf[lastln].txt := recout; recout := recout + 1; blkmove(lastln, lastln, curln); curln := curln + 1; puttxt := OK end end; -h- EDIT/reverse.p 305 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { reverse -- reverse buf[n1]...buf[n2] } procedure reverse (n1, n2 : integer); var temp : buftype; begin while (n1 < n2) do begin temp := buf[n1]; buf[n1] := buf[n2]; buf[n2] := temp; n1 := n1 + 1; n2 := n2 - 1 end end; -h- EDIT/seek.p 520 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { seek (UCB) -- special version of primitive for edit } procedure seek (recno : integer; var fd : filedesc); var junk : boolean; temp : string; begin flush(openlist[scrout].filevar); { necessary for UCB } if (recno < recin) then begin close(fd); { cheat: open scratch file by name } fd := mustopen(edittemp, IOREAD); recin := 1; end; while (recin < recno) do begin junk := getline(temp, fd, MAXSTR); recin := recin + 1 end end; -h- EDIT/setbuf1.p 272 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { setbuf (in memory) -- initialize line storage buffer } procedure setbuf; var null : string; { value is '' } begin null[1] := ENDSTR; scopy(null, 1, buf[0].txt, 1); curln := 0; lastln := 0 end; -h- EDIT/setbuf2.p 521 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { setbuf (scratch file) -- create scratch file, set up line 0 } procedure setbuf; begin { setstring(edittemp, 'edtemp'); } edittemp[1] := ord('e'); edittemp[2] := ord('d'); edittemp[3] := ord('t'); edittemp[4] := ord('e'); edittemp[5] := ord('m'); edittemp[6] := ord('p'); edittemp[7] := ENDSTR; scrout := mustcreate(edittemp, IOWRITE); scrin := mustopen(edittemp, IOREAD); recout := 1; recin := 1; curln := 0; lastln := 0 end; -h- EDIT/skipbl.p 236 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { skipbl -- skip blanks and tabs at s[i]... } procedure skipbl (var s : string; var i : integer); begin while (s[i] = BLANK) or (s[i] = TAB) do i := i + 1 end; -h- EDIT/stclose.p 427 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { stclose -- insert closure entry at pat[j] } procedure stclose (var pat : string; var j : integer; lastj : integer); var jp, jt : integer; junk : boolean; begin for jp := j-1 downto lastj do begin jt := jp + CLOSIZE; junk := addstr(pat[jp], pat, jt, MAXPAT) end; j := j + CLOSIZE; pat[lastj] := CLOSURE { where original pattern began } end; -h- EDIT/subline.p 622 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { subline -- substitute sub for pat in lin and print } procedure subline (var lin, pat, sub : string); var i, lastm, m : integer; junk : boolean; #include "amatch.p" #include "putsub.p" begin lastm := 0; i := 1; while (lin[i] <> ENDSTR) do begin m := amatch(lin, i, pat, 1); if (m > 0) and (lastm <> m) then begin { replace matched text } putsub(lin, i, m, sub); lastm := m end; if (m = 0) or (m = i) then begin { no match or null match } putc(lin[i]); i := i + 1 end else { skip matched text } i := m end end; -h- EDIT/subst.p 1358 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { subst -- substitute "sub" for occurrences of pattern } function subst (var sub : string; gflag, glob : boolean) : stcode; var new, old : string; j, k, lastm, line, m : integer; stat : stcode; done, subbed, junk : boolean; begin if (glob) then stat := OK else stat := ERR; done := (line1 <= 0); line := line1; while (not done) and (line <= line2) do begin j := 1; subbed := false; gettxt(line, old); lastm := 0; k := 1; while (old[k] <> ENDSTR) do begin if (gflag) or (not subbed) then m := amatch(old, k, pat, 1) else m := 0; if (m > 0) and (lastm <> m) then begin { replace matched text } subbed := true; catsub(old, k, m, sub, new, j, MAXSTR); lastm := m end; if (m = 0) or (m = k) then begin { no match or null match } junk := addstr(old[k], new, j, MAXSTR); k := k + 1 end else { skip matched text } k := m end; if (subbed) then begin if (not addstr(ENDSTR, new, j, MAXSTR)) then begin stat := ERR; done := true end else begin stat := lndelete(line, line, status); stat := puttxt(new); line2 := line2+curln-line; line := curln; if (stat = ERR) then done := true else stat := OK end end; line := line + 1 end; subst := stat end; -h- FORMAT/break.p 275 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { break -- end current filled line } procedure break; begin if (outp > 0) then begin outbuf[outp] := NEWLINE; outbuf[outp+1] := ENDSTR; put(outbuf) end; outp := 0; outw := 0; outwds := 0 end; -h- FORMAT/center.p 214 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { center -- center a line by setting tival } procedure center (var buf : string); begin tival := max((rmval+tival-width(buf)) div 2, 0) end; -h- FORMAT/command.p 1173 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { command -- perform formatting command } procedure command (var buf : string); var cmd : cmdtype; argtype, spval, val : integer; begin cmd := getcmd(buf); if (cmd <> UNKNOWN) then val := getval(buf, argtype); case cmd of FI: begin break; fill := true end; NF: begin break; fill := false end; BR: break; LS: setparam(lsval, val, argtype, 1, 1, HUGE); CE: begin break; setparam(ceval, val, argtype, 1, 0, HUGE) end; UL: setparam(ulval, val, argtype, 1, 0, HUGE); HE: gettl(buf, header); FO: gettl(buf, footer); BP: begin page; setparam(curpage,val,argtype,curpage+1,-HUGE,HUGE); newpage := curpage end; SP: begin setparam(spval, val, argtype, 1, 0, HUGE); space(spval) end; IND: setparam(inval, val, argtype, 0, 0, rmval-1); RM: setparam(rmval, val, argtype, PAGEWIDTH, inval+tival+1, HUGE); TI: begin break; setparam(tival, val, argtype, 0, -HUGE, rmval) end; PL: begin setparam(plval, val, argtype, PAGELEN, m1val+m2val+m3val+m4val+1, HUGE); bottom := plval - m3val - m4val end; UNKNOWN: { ignore } end end; -h- FORMAT/fmtcons.p 196 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fmtcons -- constants for format } const CMD = PERIOD; PAGENUM = SHARP; PAGEWIDTH = 60; PAGELEN = 66; HUGE = 10000; -h- FORMAT/fmtproc.p 571 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { fmtproc -- procedures needed for format } #include "skipbl.p" #include "skip.p" #include "getcmd.p" #include "setparam.p" #include "getval.p" #include "gettl.p" #include "puttl.p" #include "puthead.p" #include "putfoot.p" #include "width.p" #include "put.p" #include "break.p" #include "space.p" #include "page.p" #include "leadbl.p" #include "spread.p" #include "putword.p" #include "getword.p" #include "center.p" #include "underln.p" #include "initfmt.p" #include "command.p" #include "text.p" -h- FORMAT/format.p 1820 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { format -- text formatter main program (final version) } procedure format; #include "fmtcons.p" type cmdtype = (BP, BR, CE, FI, FO, HE, IND, LS, NF, PL, RM, SP, TI, UL, UNKNOWN); var { page parameters } curpage : integer; { current output page number; init=0 } newpage : integer; { next output page number; init=1 } lineno : integer; { next line to be printed; init=0 } plval : integer; { page length in lines; init=PAGELEN=66 } m1val : integer; { margin before and including header } m2val : integer; { margin after header } m3val : integer; { margin after last text line } m4val : integer; { bottom margin, including footer } bottom : integer; { last line on page, =plval-m3val-m4val } header : string; { top of page title; init=NEWLINE } footer : string; { bottom of page title; init=NEWLINE } { global parameters } fill : boolean; { fill if true; init=true } lsval : integer; { current line spacing; init=1 } spval : integer; { # of lines to space } inval : integer; { current indent; >= 0; init=0 } rmval : integer; { right margin; init=PAGEWIDTH=60 } tival : integer; { current temporary indent; init=0 } ceval : integer; { # of lines to center; init=0 } ulval : integer; { # of lines to underline; init=0 } { output area } outp : integer; { last char pos in outbuf; init=0 } outw : integer; { width of text in outbuf; init=0 } outwds : integer; { number of words in outbuf; init=0 } outbuf : string; { lines to be filled collect here } dir : 0..1; { direction for blank padding } inbuf : string; { input line } #include "fmtproc.p" begin initfmt; while (getline(inbuf, STDIN, MAXSTR)) do if (inbuf[1] = CMD) then command(inbuf) else text(inbuf); page { flush last output, if any } end; -h- FORMAT/format0.p 1820 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { format -- text formatter main program (final version) } procedure format; #include "fmtcons.p" type cmdtype = (BP, BR, CE, FI, FO, HE, IND, LS, NF, PL, RM, SP, TI, UL, UNKNOWN); var { page parameters } curpage : integer; { current output page number; init = 0 } newpage : integer; { next output page number; init = 1 } lineno : integer; { next line to be printed; init = 0 } plval : integer; { page length in lines; init = PAGELEN = 66 } m1val : integer; { margin before and including header } m2val : integer; { margin after header } m3val : integer; { margin after last text line } m4val : integer; { bottom margin, including footer } bottom : integer; { last live line on page, = plval-m3val-m4val } header : string; { top of page title; init = NEWLINE } footer : string; { bottom of page title; init = NEWLINE } { global parameters } fill : boolean; { fill if true; init = true } lsval : integer; { current line spacing; init = 1 } spval : integer; { next space } inval : integer; { current indent; >= 0; init = 0 } rmval : integer; { current right margin; init = PAGEWIDTH = 60 } tival : integer; { current temporary indent; init = 0 } ceval : integer; { number of lines to center; init = 0 } ulval : integer; { number of lines to underline; init = 0 } { output area } outp : integer; { last char position in outbuf; init = 0 } outw : integer; { width of text currently in outbuf; init = 0 } outwds : integer; { number of words in outbuf; init = 0 } outbuf : string; { lines to be filled collect here } dir : 0..1; inbuf : string; { input line } #include "fmtproc.p" begin initfmt; while (getline(inbuf, STDIN, MAXSTR)) do if (inbuf[1] = CMD) then command(inbuf) else text(inbuf) end; -h- FORMAT/getcmd.p 889 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getcmd -- decode command type } function getcmd (var buf : string) : cmdtype; var cmd : packed array [1..2] of char; begin cmd[1] := chr(buf[2]); cmd[2] := chr(buf[3]); if (cmd = 'fi') then getcmd := FI else if (cmd = 'nf') then getcmd := NF else if (cmd = 'br') then getcmd := BR else if (cmd = 'ls') then getcmd := LS else if (cmd = 'bp') then getcmd := BP else if (cmd = 'sp') then getcmd := SP else if (cmd = 'in') then getcmd := IND else if (cmd = 'rm') then getcmd := RM else if (cmd = 'ti') then getcmd := TI else if (cmd = 'ce') then getcmd := CE else if (cmd = 'ul') then getcmd := UL else if (cmd = 'he') then getcmd := HE else if (cmd = 'fo') then getcmd := FO else if (cmd = 'pl') then getcmd := PL else getcmd := UNKNOWN end; -h- FORMAT/gettl.p 423 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gettl -- copy title from buf to ttl } procedure gettl (var buf, ttl : string); var i : integer; begin i := 1; { skip command name } while (not (buf[i] in [BLANK, TAB, NEWLINE])) do i := i + 1; skipbl(buf, i); { find argument } if (buf[i] = SQUOTE) or (buf[i] = DQUOTE) then i := i + 1; { strip leading quote } scopy(buf, i, ttl, 1) end; -h- FORMAT/getval.p 462 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getval -- evaluate optional numeric argument } function getval (var buf : string; var argtype : integer) : integer; var i : integer; begin i := 1; { skip over command name } while (not (buf[i] in [BLANK, TAB, NEWLINE])) do i := i + 1; skipbl(buf, i); { find argument } argtype := buf[i]; if (argtype = PLUS) or (argtype = MINUS) then i := i + 1; getval := ctoi(buf, i) end; -h- FORMAT/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- FORMAT/initfmt.p 574 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { initfmt -- set format parameters to default values } procedure initfmt; begin fill := true; dir := 0; inval := 0; rmval := PAGEWIDTH; tival := 0; lsval := 1; spval := 0; ceval := 0; ulval := 0; lineno := 0; curpage := 0; newpage := 1; plval := PAGELEN; m1val := 3; m2val := 2; m3val := 2; m4val := 3; bottom := plval - m3val - m4val; header[1] := NEWLINE; { initial titles } header[2] := ENDSTR; footer[1] := NEWLINE; footer[2] := ENDSTR; outp := 0; outw := 0; outwds := 0 end; -h- FORMAT/leadbl.p 402 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { leadbl -- delete leading blanks, set tival } procedure leadbl (var buf : string); var i, j : integer; begin break; i := 1; while (buf[i] = BLANK) do { find 1st non-blank } i := i + 1; if (buf[i] <> NEWLINE) then tival := tival + i - 1; for j := i to length(buf)+1 do { move line to left } buf[j-i+1] := buf[j] end; -h- FORMAT/page.p 247 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { page -- get to top of new page } procedure page; begin break; if (lineno > 0) and (lineno <= bottom) then begin skip(bottom+1-lineno); putfoot end; lineno := 0 end; -h- FORMAT/put.p 447 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { put -- put out line with proper spacing and indenting } procedure put (var buf : string); var i : integer; begin if (lineno <= 0) or (lineno > bottom) then puthead; for i := 1 to inval + tival do { indenting } putc(BLANK); tival := 0; putstr(buf, STDOUT); skip(min(lsval-1, bottom-lineno)); lineno := lineno + lsval; if (lineno > bottom) then putfoot end; -h- FORMAT/putfoot.p 225 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putfoot -- put out page footer } procedure putfoot; begin skip(m3val); if (m4val > 0) then begin puttl(footer, curpage); skip(m4val-1) end end; -h- FORMAT/puthead.p 301 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { puthead -- put out page header } procedure puthead; begin curpage := newpage; newpage := newpage + 1; if (m1val > 0) then begin skip(m1val-1); puttl(header, curpage) end; skip(m2val); lineno := m1val + m2val + 1 end; -h- FORMAT/puttl.p 317 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { puttl -- put out title line with optional page number } procedure puttl (var buf : string; pageno : integer); var i : integer; begin for i := 1 to length(buf) do if (buf[i] = PAGENUM) then putdec(pageno, 1) else putc(buf[i]) end; -h- FORMAT/putword.p 809 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putword -- put word in outbuf; does margin justification } procedure putword (var wordbuf : string); var last, llval, nextra, w : integer; begin w := width(wordbuf); last := length(wordbuf) + outp + 1; { new end of outbuf } llval := rmval - tival - inval; if (outp > 0) and ((outw+w > llval) or (last >= MAXSTR)) then begin last := last - outp; { remember end of wordbuf } nextra := llval - outw + 1; if (nextra > 0) and (outwds > 1) then begin spread(outbuf, outp, nextra, outwds); outp := outp + nextra end; break { flush previous line } end; scopy(wordbuf, 1, outbuf, outp+1); outp := last; outbuf[outp] := BLANK; { blank between words } outw := outw + w + 1; { 1 for blank } outwds := outwds + 1 end; -h- FORMAT/putword0.p 633 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putword -- put word in outbuf } procedure putword (var wordbuf : string); var last, llval, nextra, w : integer; begin w := width(wordbuf); last := length(wordbuf) + outp + 1; { new end of outbuf } llval := rmval - tival - inval; if (outp > 0) and ((outw+w > llval) or (last >= MAXSTR)) then begin last := last - outp; { remember end of wordbuf } break { flush previous line } end; scopy(wordbuf, 1, outbuf, outp+1); outp := last; outbuf[outp] := BLANK; { blank between words } outw := outw + w + 1; { 1 for blank } outwds := outwds + 1 end; -h- FORMAT/setparam.p 518 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { setparam -- set parameter and check range } procedure setparam (var param : integer; val, argtype, defval, minval, maxval : integer); begin if (argtype = NEWLINE) then { defaulted } param := defval else if (argtype = PLUS) then { relative + } param := param + val else if (argtype = MINUS) then { relative - } param := param - val else { absolute } param := val; param := min(param, maxval); param := max(param, minval) end; -h- FORMAT/skip.p 202 { 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- FORMAT/skipbl.p 236 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { skipbl -- skip blanks and tabs at s[i]... } procedure skipbl (var s : string; var i : integer); begin while (s[i] = BLANK) or (s[i] = TAB) do i := i + 1 end; -h- FORMAT/space.p 343 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { space -- space n lines or to bottom of page } procedure space (n : integer); begin break; if (lineno <= bottom) then begin if (lineno <= 0) then puthead; skip(min(n, bottom+1-lineno)); lineno := lineno + n; if (lineno > bottom) then putfoot end end; -h- FORMAT/spread.p 816 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { spread -- spread words to justify right margin } procedure spread (var buf : string; outp, nextra, outwds : integer); var i, j, nb, nholes : integer; begin if (nextra > 0) and (outwds > 1) then begin dir := 1 - dir; { reverse previous direction } nholes := outwds - 1; i := outp - 1; j := min(MAXSTR-2, i+nextra); { room for NEWLINE } while (i < j) do begin { and ENDSTR } buf[j] := buf[i]; if (buf[i] = BLANK) then begin if (dir = 0) then nb := (nextra-1) div nholes + 1 else nb := nextra div nholes; nextra := nextra - nb; nholes := nholes - 1; while (nb > 0) do begin j := j - 1; buf[j] := BLANK; nb := nb - 1 end end; i := i - 1; j := j - 1 end end end; -h- FORMAT/text.p 762 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { text -- process text lines (final version) } procedure text (var inbuf : string); var wordbuf : string; i : integer; begin if (inbuf[1] = BLANK) or (inbuf[1] = NEWLINE) then leadbl(inbuf); { move left, set tival } if (ulval > 0) then begin { underlining } underln(inbuf, MAXSTR); ulval := ulval - 1 end; if (ceval > 0) then begin { centering } center(inbuf); put(inbuf); ceval := ceval - 1 end else if (inbuf[1] = NEWLINE) then { all-blank line } put(inbuf) else if (not fill) then { unfilled text } put(inbuf) else begin { filled text } i := 1; repeat i := getword(inbuf, i, wordbuf); if (i > 0) then putword(wordbuf) until (i = 0) end end; -h- FORMAT/text0.p 183 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { text -- process text lines (interim version 1) } procedure text (var inbuf : string); begin put(inbuf) end; -h- FORMAT/text1.p 567 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { text -- process text lines (interim version 2) } procedure text (var inbuf : string); var wordbuf : string; i : integer; begin if (inbuf[1] = BLANK) or (inbuf[1] = NEWLINE) then leadbl(inbuf); { move left, set tival } if (inbuf[1] = NEWLINE) then { all blank line } put(inbuf) else if (not fill) then { unfilled text } put(inbuf) else begin { filled text } i := 1; repeat i := getword(inbuf, i, wordbuf); if (i > 0) then putword(wordbuf) until (i = 0) end end; -h- FORMAT/underln.p 553 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { underln -- underline a line } procedure underln (var buf : string; size : integer); var i, j : integer; tbuf : string; begin j := 1; { expand into tbuf } i := 1; while (buf[i] <> NEWLINE) and (j < size-1) do begin if (isalphanum(buf[i])) then begin tbuf[j] := UNDERLINE; tbuf[j+1] := BACKSPACE; j := j + 2 end; tbuf[j] := buf[i]; j := j + 1; i := i + 1 end; tbuf[j] := NEWLINE; tbuf[j+1] := ENDSTR; scopy(tbuf, 1, buf, 1) { copy it back to buf } end; -h- FORMAT/width.p 377 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { width -- compute width of character string } function width (var buf : string) : integer; var i, w : integer; begin w := 0; i := 1; while (buf[i] <> ENDSTR) do begin if (buf[i] = BACKSPACE) then w := w - 1 else if (buf[i] <> NEWLINE) then w := w + 1; i := i + 1 end; width := w end; -h- MACRO/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- MACRO/defcons.p 339 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { defcons -- const declarations for define } const BUFSIZE = 500; { size of pushback buffer } MAXCHARS = 5000; { size of name-defn table } MAXDEF = MAXSTR; { max chars in a defn } MAXTOK = MAXSTR; { max chars in a token } HASHSIZE = 53; { size of hash table } -h- MACRO/define.p 836 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { define -- simple string replacement macro processor } procedure define; #include "defcons.p" #include "deftype.p" #include "defvar.p" defn : string; token : string; toktype : sttype; { type returned by lookup } defname : string; { value is 'define' } null : string; { value is '' } #include "defproc.p" begin null[1] := ENDSTR; initdef; install(defname, null, DEFTYPE); while (gettok(token, MAXTOK) <> ENDFILE) do if (not isletter(token[1])) then putstr(token, STDOUT) else if (not lookup(token, defn, toktype)) then putstr(token, STDOUT) { undefined } else if (toktype = DEFTYPE) then begin { defn } getdef(token, MAXTOK, defn, MAXDEF); install(token, defn, MACTYPE) end else pbstr(defn) { push replacement onto input } end; -h- MACRO/defproc.p 379 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { defproc -- procedures needed by define } #include "cscopy.p" #include "sccopy.p" #include "putback.p" #include "getpbc.p" #include "pbstr.p" #include "gettok.p" #include "getdef.p" #include "inithash.p" #include "hash.p" #include "hashfind.p" #include "install.p" #include "lookup.p" #include "initdef.p" -h- MACRO/deftype.p 417 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { deftype -- type definitions for define } type charpos = 1..MAXCHARS; charbuf = array [1..MAXCHARS] of character; sttype = (DEFTYPE, MACTYPE); { symbol table types } ndptr = ^ndblock; { pointer to a name-defn block } ndblock = record { name-defn block } name : charpos; defn : charpos; kind : sttype; nextptr : ndptr end; -h- MACRO/defvar.p 346 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { defvar -- var declarations for define } var hashtab : array [1..HASHSIZE] of ndptr; ndtable : charbuf; nexttab : charpos; { first free position in ndtable } buf : array [1..BUFSIZE] of character; { for pushback } bp : 0..BUFSIZE; { next available character; init=0 } -h- MACRO/dochq.p 473 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dochq -- change quote characters } procedure dochq (var argstk : posbuf; i, j : integer); var temp : string; n : integer; begin cscopy(evalstk, argstk[i+2], temp); n := length(temp); if (n <= 0) then begin lquote := ord(GRAVE); rquote := ord(ACUTE) end else if (n = 1) then begin lquote := temp[1]; rquote := lquote end else begin lquote := temp[1]; rquote := temp[2] end end; -h- MACRO/dodef.p 350 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dodef -- install definition in table } procedure dodef (var argstk : posbuf; i, j : integer); var temp1, temp2 : string; begin if (j - i > 2) then begin cscopy(evalstk, argstk[i+2], temp1); cscopy(evalstk, argstk[i+3], temp2); install(temp1, temp2, MACTYPE) end end; -h- MACRO/doexpr.p 296 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { doexpr -- evaluate arithmetic expressions } procedure doexpr (var argstk : posbuf; i, j : integer); var temp : string; junk : integer; begin cscopy(evalstk, argstk[i+2], temp); junk := 1; pbnum(expr(temp, junk)) end; -h- MACRO/doif.p 507 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { doif -- select one of two arguments } procedure doif (var argstk : posbuf; i, j : integer); var temp1, temp2, temp3 : string; begin if (j - i >= 4) then begin cscopy(evalstk, argstk[i+2], temp1); cscopy(evalstk, argstk[i+3], temp2); if (equal(temp1, temp2)) then cscopy(evalstk, argstk[i+4], temp3) else if (j - i >= 5) then cscopy(evalstk, argstk[i+5], temp3) else temp3[1] := ENDSTR; pbstr(temp3) end end; -h- MACRO/dolen.p 305 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dolen -- return length of argument } procedure dolen(var argstk : posbuf; i, j : integer); var temp : string; begin if (j - i > 1) then begin cscopy(evalstk, argstk[i+2], temp); pbnum(length(temp)) end else pbnum(0) end; -h- MACRO/dosub.p 734 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { dosub -- select substring } procedure dosub (var argstk : posbuf; i, j : integer); var ap, fc, k, nc : integer; temp1, temp2 : string; begin if (j - i >= 3) then begin if (j - i < 4) then nc := MAXTOK else begin cscopy(evalstk, argstk[i+4], temp1); k := 1; nc := expr(temp1, k) end; cscopy(evalstk, argstk[i+3], temp1); { origin } ap := argstk[i+2]; { target string } k := 1; fc := ap + expr(temp1, k) - 1; { first char } cscopy(evalstk, ap, temp2); if (fc >= ap) and (fc < ap+length(temp2)) then begin cscopy(evalstk, fc, temp1); for k := fc+min(nc,length(temp1))-1 downto fc do putback(evalstk[k]) end end end; -h- MACRO/eval.p 1083 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { eval -- expand args i..j: do built-in or push back defn } procedure eval (var argstk : posbuf; td : sttype; i, j : integer); var argno, k, t : integer; temp : string; begin t := argstk[i]; if (td = DEFTYPE) then dodef(argstk, i, j) else if (td = EXPRTYPE) then doexpr(argstk, i, j) else if (td = SUBTYPE) then dosub(argstk, i, j) else if (td = IFTYPE) then doif(argstk, i, j) else if (td = LENTYPE) then dolen(argstk, i, j) else if (td = CHQTYPE) then dochq(argstk, i, j) else begin k := t; while (evalstk[k] <> ENDSTR) do k := k + 1; k := k - 1; { last character of defn } while (k > t) do begin if (evalstk[k-1] <> ARGFLAG) then putback(evalstk[k]) else begin argno := ord(evalstk[k]) - ord('0'); if (argno >= 0) and (argno < j-i) then begin cscopy(evalstk, argstk[i+argno+1], temp); pbstr(temp) end; k := k - 1 { skip over $ } end; k := k - 1 end; if (k = t) then { do last character } putback(evalstk[k]) end end; -h- MACRO/expr.p 462 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { expr -- recursive expression evaluation } function expr (var s : string; var i : integer) : integer; var v : integer; t : character; #include "gnbchar.p" #include "term.p" begin v := term(s, i); t := gnbchar(s, i); while (t in [PLUS, MINUS]) do begin i := i + 1; if (t = PLUS) then v := v + term(s, i) else v := v - term(s, i); t := gnbchar(s, i) end; expr := v end; -h- MACRO/factor.p 413 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { factor -- evaluate factor of arithmetic expression } function factor (var s : string; var i : integer) : integer; begin if (gnbchar(s, i) = LPAREN) then begin i := i + 1; factor := expr(s, i); if (gnbchar(s, i) = RPAREN) then i := i + 1 else message('macro: missing paren in expr') end else factor := ctoi(s, i) end; -h- MACRO/getdef.p 1122 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getdef -- get name and definition } procedure getdef (var token : string; toksize : integer; var defn : string; defsize : integer); var i, nlpar : integer; c : character; begin token[1] := ENDSTR; { in case of bad input } defn[1] := ENDSTR; if (getpbc(c) <> LPAREN) then message('define: missing left paren') else if (not isletter(gettok(token, toksize))) then message('define: non-alphanumeric name') else if (getpbc(c) <> COMMA) then message('define: missing comma in define') else begin { got '(name,' so far } while (getpbc(c) = BLANK) do ; { skip leading blanks } putback(c); { went one too far } nlpar := 0; i := 1; while (nlpar >= 0) do begin if (i >= defsize) then error('define: definition too long') else if (getpbc(defn[i]) = ENDFILE) then error('define: missing right paren') else if (defn[i] = LPAREN) then nlpar := nlpar + 1 else if (defn[i] = RPAREN) then nlpar := nlpar - 1; { else normal character in defn[i] } i := i + 1 end; defn[i-1] := ENDSTR end end; -h- MACRO/getpbc.p 323 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { getpbc -- get a (possibly pushed back) character } function getpbc (var c : character) : character; begin if (bp > 0) then c := buf[bp] else begin bp := 1; buf[bp] := getc(c) end; if (c <> ENDFILE) then bp := bp - 1; getpbc := c end; -h- MACRO/gettok.p 591 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gettok -- get token for define } function gettok (var token : string; toksize : integer) : character; var i : integer; done : boolean; begin i := 1; done := false; while (not done) and (i < toksize) do if (isalphanum(getpbc(token[i]))) then i := i + 1 else done := true; if (i >= toksize) then error('define: token too long'); if (i > 1) then begin { some alpha was seen } putback(token[i]); i := i - 1 end; { else single non-alphanumeric } token[i+1] := ENDSTR; gettok := token[1] end; -h- MACRO/gnbchar.p 266 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { gnbchar -- get next non-blank character } function gnbchar (var s : string; var i : integer) : character; begin while (s[i] in [BLANK, TAB, NEWLINE]) do i := i + 1; gnbchar := s[i] end; -h- MACRO/hash.p 287 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { hash -- compute hash function of a name } function hash (var name : string) : integer; var i, h : integer; begin h := 0; for i := 1 to length(name) do h := (3 * h + name[i]) mod HASHSIZE; hash := h + 1 end; -h- MACRO/hashfind.p 447 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { hashfind -- find name in hash table } function hashfind (var name : string) : ndptr; var p : ndptr; tempname : string; found : boolean; begin found := false; p := hashtab[hash(name)]; while (not found) and (p <> nil) do begin cscopy(ndtable, p^.name, tempname); if (equal(name, tempname)) then found := true else p := p^.nextptr end; hashfind := p end; -h- MACRO/initdef.p 412 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { initdef -- initialize variables for define } procedure initdef; begin { setstring(defname, 'define'); } defname[1] := ord('d'); defname[2] := ord('e'); defname[3] := ord('f'); defname[4] := ord('i'); defname[5] := ord('n'); defname[6] := ord('e'); defname[7] := ENDSTR; bp := 0; { pushback buffer pointer } inithash end; -h- MACRO/inithash.p 261 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { inithash -- initialize hash table to nil } procedure inithash; var i : 1..HASHSIZE; begin nexttab := 1; { first free slot in table } for i := 1 to HASHSIZE do hashtab[i] := nil end; -h- MACRO/initmacro.p 1446 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { initmacro -- initialize variables for macro } procedure initmacro; begin null[1] := ENDSTR; { setstring(defname, 'define'); } defname[1] := ord('d'); defname[2] := ord('e'); defname[3] := ord('f'); defname[4] := ord('i'); defname[5] := ord('n'); defname[6] := ord('e'); defname[7] := ENDSTR; { setstring(subname, 'substr'); } subname[1] := ord('s'); subname[2] := ord('u'); subname[3] := ord('b'); subname[4] := ord('s'); subname[5] := ord('t'); subname[6] := ord('r'); subname[7] := ENDSTR; { setstring(exprname, 'expr'); } exprname[1] := ord('e'); exprname[2] := ord('x'); exprname[3] := ord('p'); exprname[4] := ord('r'); exprname[5] := ENDSTR; { setstring(ifname, 'ifelse'); } ifname[1] := ord('i'); ifname[2] := ord('f'); ifname[3] := ord('e'); ifname[4] := ord('l'); ifname[5] := ord('s'); ifname[6] := ord('e'); ifname[7] := ENDSTR; { setstring(lenname, 'len'); } lenname[1] := ord('l'); lenname[2] := ord('e'); lenname[3] := ord('n'); lenname[4] := ENDSTR; { setstring(chqname, 'changeq'); } chqname[1] := ord('c'); chqname[2] := ord('h'); chqname[3] := ord('a'); chqname[4] := ord('n'); chqname[5] := ord('g'); chqname[6] := ord('e'); chqname[7] := ord('q'); chqname[8] := ENDSTR; bp := 0; { pushback buffer pointer } inithash; lquote := ord(GRAVE); rquote := ord(ACUTE) end; -h- MACRO/install.p 727 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { install -- add name, definition and type to table } procedure install (var name, defn : string; t : sttype); var h, dlen, nlen : integer; p : ndptr; begin nlen := length(name) + 1; { 1 for ENDSTR } dlen := length(defn) + 1; if (nexttab + nlen + dlen > MAXCHARS) then begin putstr(name, STDERR); error(': too many definitions') end else begin { put it at front of chain } h := hash(name); new(p); p^.nextptr := hashtab[h]; hashtab[h] := p; p^.name := nexttab; sccopy(name, ndtable, nexttab); nexttab := nexttab + nlen; p^.defn := nexttab; sccopy(defn, ndtable, nexttab); nexttab := nexttab + dlen; p^.kind := t end end; -h- MACRO/lookup.p 369 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { lookup -- locate name, get defn and type from table } function lookup (var name, defn : string; var t : sttype) : boolean; var p : ndptr; begin p := hashfind(name); if (p = nil) then lookup := false else begin lookup := true; cscopy(ndtable, p^.defn, defn); t := p^.kind end end; -h- MACRO/maccons.p 494 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { maccons -- const declarations for macro } const BUFSIZE = 1000; { size of pushback buffer } MAXCHARS = 5000; { size of name-defn table } MAXPOS = 500; { size of position arrays } CALLSIZE = MAXPOS; ARGSIZE = MAXPOS; EVALSIZE = MAXCHARS; MAXDEF = MAXSTR; { max chars in a defn } MAXTOK = MAXSTR; { max chars in a token } HASHSIZE = 53; { size of hash table } ARGFLAG = DOLLAR; { macro invocation character } -h- MACRO/macproc.p 581 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { macproc -- procedures for macro } #include "cscopy.p" #include "sccopy.p" #include "putback.p" #include "getpbc.p" #include "pbstr.p" #include "pbnum.p" #include "gettok.p" #include "inithash.p" #include "hash.p" #include "hashfind.p" #include "install.p" #include "lookup.p" #include "push.p" #include "putchr.p" #include "puttok.p" #include "expr.p" #include "dodef.p" #include "doif.p" #include "doexpr.p" #include "dolen.p" #include "dochq.p" #include "dosub.p" #include "eval.p" #include "initmacro.p" -h- MACRO/macro.p 2396 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { macro -- expand macros with arguments } procedure macro; #include "maccons.p" #include "mactype.p" #include "macvar.p" defn : string; token : string; toktype : sttype; t : character; nlpar : integer; #include "macproc.p" begin initmacro; install(defname, null, DEFTYPE); install(exprname, null, EXPRTYPE); install(subname, null, SUBTYPE); install(ifname, null, IFTYPE); install(lenname, null, LENTYPE); install(chqname, null, CHQTYPE); cp := 0; ap := 1; ep := 1; while (gettok(token, MAXTOK) <> ENDFILE) do if (isletter(token[1])) then begin if (not lookup(token, defn, toktype)) then puttok(token) else begin { defined; put it in eval stack } cp := cp + 1; if (cp > CALLSIZE) then error('macro: call stack overflow'); callstk[cp] := ap; typestk[cp] := toktype; ap := push(ep, argstk, ap); puttok(defn); { push definition } putchr(ENDSTR); ap := push(ep, argstk, ap); puttok(token); { stack name } putchr(ENDSTR); ap := push(ep, argstk, ap); t := gettok(token, MAXTOK); { peek at next } pbstr(token); if (t <> LPAREN) then begin { add () } putback(RPAREN); putback(LPAREN) end; plev[cp] := 0 end end else if (token[1] = lquote) then begin { strip quotes } nlpar := 1; repeat t := gettok(token, MAXTOK); if (t = rquote) then nlpar := nlpar - 1 else if (t = lquote) then nlpar := nlpar + 1 else if (t = ENDFILE) then error('macro: missing right quote'); if (nlpar > 0) then puttok(token) until (nlpar = 0) end else if (cp = 0) then { not in a macro at all } puttok(token) else if (token[1] = LPAREN) then begin if (plev[cp] > 0) then puttok(token); plev[cp] := plev[cp] + 1 end else if (token[1] = RPAREN) then begin plev[cp] := plev[cp] - 1; if (plev[cp] > 0) then puttok(token) else begin { end of argument list } putchr(ENDSTR); eval(argstk, typestk[cp], callstk[cp], ap-1); ap := callstk[cp]; { pop eval stack } ep := argstk[ap]; cp := cp - 1 end end else if (token[1]=COMMA) and (plev[cp]=1) then begin putchr(ENDSTR); { new argument } ap := push(ep, argstk, ap) end else puttok(token); { just stack it } if (cp <> 0) then error('macro: unexpected end of input') end; -h- MACRO/mactype.p 468 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { mactype -- type declarations for macro } type charpos = 1..MAXCHARS; charbuf = array [1..MAXCHARS] of character; posbuf = array [1..MAXPOS] of charpos; pos = 0..MAXPOS; sttype = (DEFTYPE, MACTYPE, IFTYPE, SUBTYPE, EXPRTYPE, LENTYPE, CHQTYPE); { symbol table types } ndptr = ^ndblock; ndblock = record name : charpos; defn : charpos; kind : sttype; nextptr : ndptr end; -h- MACRO/macvar.p 1107 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { macvar -- var declarations for macro } var buf : array [1..BUFSIZE] of character; { for pushback } bp : 0..BUFSIZE; { next available character; init=0 } hashtab : array [1..HASHSIZE] of ndptr; ndtable : charbuf; nexttab : charpos; { first free position in ndtable } callstk : posbuf; { call stack } cp : pos; { current call stack position } typestk : array[1..CALLSIZE] of sttype; { type } plev : array [1..CALLSIZE] of integer; { paren level } argstk : posbuf; { argument stack for this call } ap : pos; { current argument position } evalstk : charbuf; { evaluation stack } ep : charpos; { first character unused in evalstk } { built-ins: } defname : string; { value is 'define' } exprname : string; { value is 'expr' } subname : string; { value is 'substr' } ifname : string; { value is 'ifelse' } lenname : string; { value is 'len' } chqname : string; { value is 'changeq' } null : string; { value is '' } lquote : character; { left quote character } rquote : character; { right quote character } -h- MACRO/pbnum.p 249 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { pbnum -- convert number to string, push back on input } procedure pbnum (n : integer); var temp : string; junk : integer; begin junk := itoc(n, temp, 1); pbstr(temp) end; -h- MACRO/pbstr.p 224 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { pbstr -- push string back onto input } procedure pbstr (var s : string); var i : integer; begin for i := length(s) downto 1 do putback(s[i]) end; -h- MACRO/push.p 319 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { push -- push ep onto argstk, return new position ap } function push (ep : integer; var argstk : posbuf; ap : integer) : integer; begin if (ap > ARGSIZE) then error('macro: argument stack overflow'); argstk[ap] := ep; push := ap + 1 end; -h- MACRO/putback.p 263 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putback -- push character back onto input } procedure putback (c : character); begin if (bp >= BUFSIZE) then error('too many characters pushed back'); bp := bp + 1; buf[bp] := c end; -h- MACRO/putchr.p 332 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { putchr -- put single char on output or evaluation stack } procedure putchr (c : character); begin if (cp <= 0) then putc(c) else begin if (ep > EVALSIZE) then error('macro: evaluation stack overflow'); evalstk[ep] := c; ep := ep + 1 end end; -h- MACRO/puttok.p 266 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { puttok -- put token on output or evaluation stack } procedure puttok (var s : string); var i : integer; begin i := 1; while (s[i] <> ENDSTR) do begin putchr(s[i]); i := i + 1 end end; -h- MACRO/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- MACRO/term.p 514 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } { term -- evaluate term of arithmetic expression } function term (var s : string; var i : integer) : integer; var v : integer; t : character; #include "factor.p" begin v := factor(s, i); t := gnbchar(s, i); while (t in [STAR, SLASH, PERCENT]) do begin i := i + 1; case t of STAR: v := v * factor(s, i); SLASH: v := v div factor(s, i); PERCENT: v := v mod factor(s, i) end; t := gnbchar(s, i) end; term := v end; -h- MAN/archive.m 1987 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM archive maintain file archive .SY .UL "archive -cmd aname [ file ... ]" .FU .UL archive manages any number of member files in a single file, .UL aname , with sufficient information that members may be selectively added, extracted, replaced, or deleted from the collection. .UL -cmd is a code that determines the operation to be performed: .P1 -c\f1 create a new archive with named members\fP -d\f1 delete named members from archive\fP -p\f1 print named members on standard output\fP -t\f1 print table of archive contents\fP -u\f1 update named members or add at end\fP -x\f1 extract named members from archive\fP .P2 In each case, the ``named members'' are the zero or more filenames given as arguments following .UL aname . If no arguments follow, then the ``named members'' are taken as .ul all of the files in the archive, except for the delete command .UL -d , which is not so rash. .UL archive complains if a file is named twice or cannot be accessed. .IP The .UL -t command writes one line to the output for each named member, consisting of the member name and a string representation of the file length, separated by a blank. .IP The create command .UL -c makes a new archive containing the named files. The update command .UL -u replaces existing named members and adds new files onto the end of an existing archive. Create and update read from, and extract writes to, files whose names are the same as the member names in the archive. An intermediate version of the new archive file is first written to the file .UL artemp ; hence this filename should be avoided. .IP An archive is a concatenation of zero or more entries, each consisting of a header and an exact copy of the original file. The header format is .Q1 .Q2 .EG To replace two files in an existing archive, add a new one, then print the table of contents: .Q1 archive -u archfile old1 old2 new1 archive -t archfile .Q2 -h- MAN/change.m 840 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM change change patterns in text .SY .UL "change pattern [newstuff]" .FU .UL change copies its input to its output except that each non-overlapping string that matches .UL pattern is replaced by the string .UL newstuff . A non-existent .UL newstuff implies deletion of the matched string. The patterns accepted by .UL change are the same as those used by .UL find . .IP The replacement string .UL newstuff consists of zero or more of the following elements: .Q1 .if t .ta .5i .if n .ta 12 \f2c\fP \f1literal character\fP & \f1ditto, i.e., whatever was matched\fP @\f2c\fP \f1escaped character \fP\f2c\fP \f1(e.g., \fP@&\f1)\fP .Q2 .EG To parenthesize all sums and differences of identifiers: .Q1 change "[a-zA-Z][a-zA-Z0-9]*[ ]*[+-][ ]*[a-zA-Z][a-zA-Z0-9]*" (&) .Q2 -h- MAN/charcount.m 471 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM charcount count characters in input .SY .UL "charcount" .FU .UL charcount counts the characters in its input and writes the total as a single line of text to the output. Since each line of text is internally delimited by a .UL NEWLINE character, the total count is the number of lines plus the number of characters within each line. .EG .Q1 charcount A single line of input. .S 24 .Q2 -h- MAN/close.m 339 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM close close an open file .SY .Q1 fd : filedesc; close(fd); .Q2 .FU .UL close releases the file descriptor and any associated resources for a file opened by .UL open or .UL create . .BU Behavior is undefined for closing a file that is not open. -h- MAN/compare.m 568 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM compare compare files for equality .SY .UL "compare file1 file2" .FU .UL compare performs a line-by-line comparison of .UL file1 and .UL file2 , printing each pair of differing lines, preceded by a line containing the offending line number and a colon. If the files are identical, no output is produced. If one file is a prefix of the other, .UL compare reports end of file on the shorter file. .EG .Q1 compare old new .Q2 .BU .UL compare can produce voluminous output for small differences. -h- MAN/compress.m 839 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM compress compress input by encoding repeated characters .SY .UL "compress" .FU .UL compress copies its input to its output, replacing strings of four or more identical characters by a code sequence so that the output generally contains fewer characters than the input. A run of .UL x 's is encoded as .UL ~nx , where the count .UL n is a character: .UL A ' ` calls for a repetition of one .UL x , .UL B ' ` a repetition of two .UL x 's, and so on. Runs longer than 26 are broken into several shorter ones. Runs of .UL ~ 's of any length are encoded. .EG .Q1 compress Item Name Value .S "Item~D Name~I Value" 1 car ~$7,000.00 .S "1~G car~J ~A~$7,000.00" .BU The implementation assumes 26 legal characters beginning with .UL A . -h- MAN/concat.m 436 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM concat concatenate files .SY .UL "concat file ..." .FU .UL concat writes the contents of each of its file arguments in turn to its output, thus concatenating them into one larger file. Since .UL concat performs no reformatting or interpretation of the input files, it is useful for displaying the contents of a file. .EG To examine a file: .Q1 concat file .Q2 -h- MAN/copy.m 565 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM copy copy input to output .SY .UL copy .FU .UL copy copies its input to its output unchanged. It is useful for copying from a terminal to a file, from file to file, or even from terminal to terminal. It may be used for displaying the contents of a file, without interpretation or formatting, by copying from a file to terminal. .EG To echo lines typed at your terminal: .Q1 copy hello there, are you listening? .S "hello there, are you listening?" yes, I am. .S "yes, I am." .Q2 -h- MAN/create.m 650 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM create initialize a file for writing .SY .Q1 name : string; fd : filedesc; mode : IOREAD..IOWRITE; fd := create(name, mode); .Q2 .FU .UL create arranges for access to file .UL name with the specified access mode, which is generally .UL IOWRITE . It returns a file descriptor if the access succeeds, and .UL IOERROR if not. .UL fd may be used in subsequent calls to .UL putcf , .UL putstr , etc. .IP .UL create creates the file if it does not exist already. If the file does exist, the effect is to remove it and create it anew; it is .ul not an error. -h- MAN/define.m 879 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM define expand string definitions .SY .UL "define" .FU .UL define reads its input, looking for macro definitions of the form .Q1 define(ident, string) .Q2 and writes its output with each subsequent instance of the identifier .UL ident replaced by the sequence of characters .UL string . .UL string must be balanced in parentheses. The text of each definition proper results in no output text. Each replacement string is rescanned for further possible replacements, permitting multi-level definitions. .EG .Q1 define define(ENDFILE, (-1)) define(DONE, ENDFILE) if (getit(line) = DONE) then putit(sumline); .S " if (getit(line) = (-1)) then" .S " putit(sumline);" .Q2 .BU A recursive definition such as .UL define(x,\ x) will cause an infinite loop when .UL x is invoked. -h- MAN/detab.m 638 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM detab convert tabs to blanks .SY .UL "detab" .FU .UL detab copies its input to its output, expanding horizontal tabs to blanks along the way, so that the output is visually the same as the input, but contains no tab characters. Tab stops are assumed to be set every four columns (i.e., 1, 5, 9, ...), so that each tab character is replaced by from one to four blanks. .EG Using .UL \(-> as a visible tab: .Q1 detab \(->col 1\(->2\(->34\(->rest .S " col 1 2 34 rest" .BU .UL detab is naive about backspaces, vertical motions, and non-printing characters. -h- MAN/echo.m 385 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM echo echo arguments to output .SY .UL "echo [ argument ... ]" .FU .UL echo copies its command line arguments to its output as a line of text with one space between each argument. If there are no arguments, no output is produced. .EG To see if your system is alive: .Q1 echo hello world! .S "hello world!" .Q2 -h- MAN/edit.m 4040 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM edit edit text files .SY .UL "edit [file]" .FU .UL edit is an interactive text editor that reads command lines from its input and writes display information, upon command, to its output. It works by reading text files on command into an internal ``buffer'' (which may be quite large), displaying and modifying the buffer contents by other commands, then writing all or part of the buffer to text files, also on command. The buffer is organized as a sequence of lines, numbered from 1; lines are implicitly renumbered as text is added or deleted. .IP Context searches and substitutions are specified by writing text patterns, following the same rules for building patterns as used by .UL find . Substitutions specify replacement text following the same rules as used by the program .UL change . .IP Line numbers are formed from the following components: .P1 .if t .ta .6i .if n .ta 12 \f2n\fP \f1a decimal number\fP \&. \f1the current line (``dot'')\fP $ \f1the last line\fP /\f2pattern\fP/ \f1a forward context search\fP \e\f2pattern\fP\e \f1a backward context search\fP .P2 .IP Components may be combined with .UL + or .UL - , as in, for example, .P1 .if t .ta .6i 2.2i .if n .ta 12 \&.+1 \f1sum of \fP.\f1 and 1\fP \&$-5 \f1five lines before \fP$ \f1(\f2continued on next page\f1) .P2 .D2 .D1 .IP Line numbers are separated by commas or semicolons; a semicolon sets the current line to the most recent line number before proceeding. .IP Commands may be preceded by an arbitrary number of line numbers (except for .UL e , .UL f and .UL q , which require that none be present). The last one or two are used as needed. If two line numbers are needed and only one is specified, it is used for both. If no line numbers are specified, a default rule is applied: .P1 .if t .ta .6i .if n .ta 12 (.)\f1 use the current line\fP (.+1)\f1 use the next line\fP (.,.)\f1 use the current line for both line numbers\fP (1,$)\f1 use all lines\fP .P2 ....D2 ....D1 .IP In alphabetical order, the commands and their default line numbers are: .P1 .3i .if t .ta 0.35i 1.1i .if n .ta 6 15 (.) a \f1append text after line (text follows)\fP (.,.) c \f1change text (text follows)\fP (.,.) dp \f1delete text\fP e \f2file\fP \f1edit\fP \f2file\fP\f1 after discarding all previous text, remember file name .ft P f \f2file\fP \f1print file name, remember file name\fP (.) i \f1insert text before line (text follows)\fP (.,.) m \f2line3\fP p \f1move text to after\fP \f2line3\fP (.,.) p \f1print text\fP q \f1quit\fP (.) r \f2file\fP \f1read\fP \f2file\fP\f1, appending after line\fP (.,.) s/\f2pat\fP/\f2new\fP/gp \f1substitute\fP \f2new\fP \f1for occurrence of\fP \f2pat\fP \f1(\fPg\f1 implies for each occurrence across line)\fP (1,$) w \f2file\fP \f1write\fP \f2file\fP \f1(leaves current state unaltered)\fP (.) =p \f1print line number\fP (.+1) \f2newline\fP \f1print one line\fP .P2 .IP The trailing .UL p , which is optional, causes the last affected line to be printed. Dot is set to the last affected line, except for .UL f , .UL w , and .UL = , for which it is unchanged. .IP Text entered with .UL a , .UL c and .UL i is terminated with a line containing just a .UL . '. ` .IP The global prefixes cause repeated execution of a command, once for each line that matches .UL g ) ( or does not match .UL x ) ( a specified text pattern: .P1 (1,$) g/\f2pattern\fP/\f2command\fP (1,$) x/\f2pattern\fP/\f2command\fP .P2 .ul command can be anything but .UL a , .UL c , .UL i or .UL q , and may be preceded by line numbers as usual. Dot is set to the matched line before .ul command is done. .IP If the command line argument .UL file is present, then the editor behaves as if its input began with the command .UL "e file" . The first filename used is remembered, so that a subsequent .UL e , .UL f , .UL r , or .UL w command can be written with no filename to refer to the remembered filename. A filename given with .UL e or .UL f replaces any remembered filename. .EG Don't be silly. -h- MAN/entab.m 802 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM entab convert runs of blanks into tabs .SY .UL "entab" .FU .UL entab copies its input to its output, replacing strings of blanks by tabs so that the output is visually the same as the input, but contains fewer characters. Tab stops are assumed to be set every four columns (i.e., 1, 5, 9, ...), so that each sequence of one to four blanks ending on a tab stop is replaced by a tab character. .EG Using .UL \(-> as a visible tab: .Q1 entab col 1 2 34 rest .S "\(->col\(->1\(->2\(->34\(->rest" .Q2 .BU .UL entab is naive about backspaces, vertical motions, and non-printing characters. .br .UL entab will convert a single blank to a tab if it occurs at a tab stop. Thus .UL entab is not an exact inverse of .UL detab . -h- MAN/error.m 362 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM error,\ message print diagnostic message on STDERR .SY .Q1 s : packed array [1..\f2n\fP] of char; error(s); message(s); .Q2 .FU .UL error and .UL message write their single argument on .UL STDERR . .UL message returns, .UL error terminates execution of the program. -h- MAN/expand.m 737 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM expand expand compressed input .SY .UL "expand" .FU .UL expand copies its input, which has presumably been encoded by .UL compress , to its output, replacing code sequences .UI ~n c by the repeated characters they stand for so that the text output exactly matches that which was originally encoded. The occurrence of the warning character .UL ~ in the input means that the next character is a repetition count; .UL A ' ` calls for one instance of the following character, .UL B ' ` calls for two, and so on up to .UL Z .' ` .EG .Q1 expand Item~D Name~I Value .S "Item Name Value" 1~G car~J ~A~$7,000.00 .S "1 car ~$7,000.00" -h- MAN/find.m 1802 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM find find patterns in text .SY .UL "find pattern" .FU .UL find reads its input a line at a time and writes to its output those lines that match the specified text pattern. A text pattern is a concatenation of the following elements: .Q1 .if t .ta .5i .if n .ta 12 \f2c\fP \f1literal character\fP \f2c\fP ? \f1any character except newline\fP % \f1beginning of line\fP $ \f1end of line (null string before newline)\fP [...] \f1character class (any one of these characters)\fP [^...] \f1negated character class (all but these characters)\fP * \f1closure (zero or more occurrences of previous pattern)\fP @\f2c\fP \f1escaped character (e.g., \fP@%\f1, \fP@[\f1, \fP@*\f1)\fP .Q2 Special meaning of characters in a text pattern is lost when escaped, inside .UL [...] (except .UL @] ), or for: .Q1 .if t .ta .5i .if n .ta 12 % \f1not at beginning\fP $ \f1not at end\fP * \f1at beginning\fP .Q2 .IP A character class consists of zero or more of the following elements, surrounded by .UL [ and .UL ] : .Q1 .if t .ta .5i .if n .ta 12 \f2c\f8 \f1literal character \f2c\f1, including \f8[ \f2c1\-c2\fP \f1range of characters (digits, lower or upper case letters)\fP ^ \f1negated character class if at beginning\fP @\f2c\fP \f1escaped character (e.g., \fP@^ @- @@ @]\f1)\fP .Q2 Special meaning of characters in a character class is lost when escaped or for: .Q1 .if t .ta .5i .if n .ta 12 ^ \f1not at beginning\fP - \f1at beginning or end\fP .Q2 .IP An escape sequence consists of the character .UL @ followed by a single character: .Q1 .if t .ta .5i .if n .ta 12 @n \f1newline\fP @t \f1tab\fP @\f2c\fP \f2c\fP\f1 (including \fP@@\f1)\fP .Q2 .EG To print lines ending in a Pascal keyword or identifier: .Q1 find [a-zA-Z][a-zA-Z0-9]*$ .Q2 -h- MAN/format.m 2268 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM format produce formatted output .SY .UL "format" .FU .UL format reads its input a line at a time and writes a neatly formatted version of the input text to the output, with page headers and footers and with output lines filled to a uniform right margin. Input text lines may have interspersed among them command lines that alter this default mode of formatting. A command line consists of a leading period, followed by a two letter code, possibly with optional arguments following the first sequence of blanks and tabs. .IP Certain commands cause a ``break'' in the processing of input text lines, i.e., any partially filled line is output and a new line is begun. In the following command summary, the letter .ul n stands for an optional numeric argument. If a numeric argument is preceded by a .UL + or .UL - , the current value is .ul changed by this amount; otherwise the argument represents the new value. If no argument is given, the default value is used. .P1 .if t .ta .6i 1.1i 2i command break? default function .WS .if t .ta .05i .7i 1.2i 2i \f(\*(pf @bp \f2n \f1yes \f2n\f1=+1 begin page numbered \f2n\fP \f(\*(pf @br \f1yes \f1cause break\fP \f(\*(pf @ce \f2n \f1yes \f2n\f1=1 center next \f2n\f1 lines\fP \f(\*(pf @fi \f1yes start filling\fP \f(\*(pf @fo\f2 str \f1no empty footer title\fP \f(\*(pf @he\f2 str \f1no empty header title\fP \f(\*(pf @in \f2n \f1no\f2 n\f1=0 indent \f2n \f1spaces\fP \f(\*(pf @ls \f2n \f1no\f2 n\f1=1 line spacing is \f2n \f1\fP \f(\*(pf @nf \f1yes stop filling\fP \f(\*(pf @pl \f2n \f1no \f2n\f1=66 set page length to\f2 n\fP \f(\*(pf @rm \f2n \f1no \f2n\f1=60 set right margin to\f2 n\fP \f(\*(pf @sp \f2n \f1yes \f2n\f1=1 space down \f2n\f1 lines or to bottom of page\fP \f(\*(pf @ti \f2n \f1yes \f2n\f1=0 temporary indent of\f2 n\fP \f(\*(pf @ul \f2n \f1no \f2n\f1=1 underline words from next \f2n\f1 lines \fP .P2 .IP A blank input line causes a break and is passed to the output unchanged. Similarly, an input line that begins with blanks causes a break and is written to the output with the leading blanks preserved. Thus a document formatted in the conventional manner by hand will retain its original paragraph breaks and indentation. -h- MAN/getarg.m 572 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM getarg,\ nargs command-line argument handling .SY .Q1 arg : string; n : integer; b : boolean; b := getarg(n, arg, MAXSTR); n := nargs; .Q2 .UL getarg accesses the .UL n -th command-line argument, returns it in .UL arg , and sets .UL b to .UL true . If there is no such argument, .UL b is .UL false . The argument will be at most .UL MAXSTR characters long, including the terminating .UL ENDSTR . .IP The function .UL nargs returns the total number of available arguments. -h- MAN/getc.m 618 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM getc,\ getcf get one character from input .SY .Q1 c, c1 : character; fd : filedesc; c := getc(c1); c := getcf(c1, fd); .Q2 .FU .UL getc and .UL getcf return a single .UL character from .UL STDIN or the named file descriptor respectively. The value is also returned through the .UL c1 argument. .UL ENDFILE is returned the first time that end of file is encountered. .UL NEWLINE is returned at the end of each line. .BU There is no explicit error mechanism. .br Behavior of calls after the first .UL ENDFILE is undefined. -h- MAN/getline.m 704 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM getline get one line from file .SY .Q1 s : string; b : boolean; fd : filedesc; b := getline(s, fd, MAXSTR); .Q2 .FU .UL getline returns the next line from the specified file descriptor in the string .UL s . .UL b is .UL true if any data was returned, and .UL false for end of file. .UL getline returns at most .UL MAXSTR-1 characters plus a terminating .UL ENDSTR ; thus if .UL s[length(s)] is not a .UL NEWLINE , the input line was too long. .IP .UL getline and .UL getcf calls may be interleaved. .BU There is no explicit error mechanism. .br Behavior of calls after the first .UL ENDFILE is undefined. -h- MAN/include.m 587 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM include include copies of subfiles .SY .UL "include" .FU .UL include copies its input to its output unchanged, except that each line beginning .Q1 #include "filename" .Q2 is replaced by the contents of the file whose name is .UL filename . .UL include d files may contain further .UL #include lines, to arbitrary depth. .EG To piece together a Pascal program such as .UL include : .Q1 #include "include.p" .Q2 .BU A file that includes itself will not be diagnosed, but will eventually cause something to break. -h- MAN/kwic.m 704 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM kwic produce lines for KWIC index .SY .UL "kwic" .FU .UL kwic writes one or more ``folded'' versions of each input line to its output. A line is ``folded'' at the beginning of each alphanumeric string within the line by writing from that string through the end of the line, followed by the fold character .UL $ , followed by the beginning of the line. .IP .UL kwic is used with .UL sort and .UL unrotate to produce a KeyWord In Context, or KWIC, index. .EG .Q1 kwic This is a test. .S "This is a test.$" .S "is a test.$This" .S "a test.$This is" .S "test.$This is a" .Q2 Normal usage is .Q1 kwic .S 1 .Q2 -h- MAN/macro.m 2869 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM macro expand string definitions, with arguments .SY .UL "macro" .FU .UL macro reads its input, looking for macro definitions of the form .Q1 define(ident,string) .Q2 and writes its output with each subsequent instance of the identifier .UL ident replaced by the arbitrary sequence of characters .UL string . .IP Within a replacement string, any dollar sign .UL $ followed by a digit is replaced by an argument corresponding to that digit. Arguments are written as a parenthesized list of strings following an instance of the identifier, e.g., .Q1 ident(arg1,arg2,...) .Q2 So .UL $1 is replaced in the replacement string by .UL arg1 , .UL $2 by .UL arg2 , and so on; .UL $0 is replaced by .UL ident . Missing arguments are taken as null strings; extra arguments are ignored. .IP The replacement string in a definition is expanded before the definition occurs, except that any sequence of characters between a grave .UL ` and a balancing apostrophe .UL ' is taken literally, with the grave and apostrophe removed. Thus, it is possible to make an alias for define by writing .Q1 define(def,`define($1,$2)') .Q2 .IP Additional predefined built-ins are: .IP .UL ifelse(a,b,c,d) is replaced by the string .UL c if the string .UL a exactly matches the string .UL b ; otherwise it is replaced by the string .UL d . .IP .UL expr(expression) is replaced by the decimal string representation of the numeric value of .UL expression . For correct operation, the expression must consist of parentheses, integer operands written as decimal digit strings, and the operators .UL + , .UL - , .UL * , .UL / (integer division), and .UL % (remainder). Multiplication and division bind tighter than addition and subtraction, but parentheses may be used to alter this order. .IP .UL substr(s,m,n) is replaced by the substring of .UL s starting at location .UL m (counting from one) and continuing at most .UL n characters. If .UL n is omitted, it is taken as a very large number; if .UL m is outside the string, the replacement string is null. .UL m and .UL n may be expressions suitable for .UL expr . .IP .UL len(s) is replaced by the string representing the length of its argument in characters. .IP .UL changeq(xy) changes the quote characters to .UL x and .UL y . .UL changeq() changes them back to .UL ` and .UL ' . .IP Each replacement string is rescanned for further possible replacements, permitting multi-level definitions to be expanded to final form. .EG The macro .UL len could be written in terms of the other built-ins as: .Q1 define(`len',`ifelse($1,,0,`expr(1+len(substr($1,2)))')') .Q2 .BU A recursive definition of the form .UL define(x,x) will cause an infinite loop. .br Expression evaluation is fragile. There is no unary minus. .br It is unwise to use parentheses as quote characters. -h- MAN/makecopy.m 515 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM makecopy copy a file to new file .SY .UL "makecopy old new" .FU .UL makecopy copies the file .UL old to a new instance of the file .UL new , i.e., if .UL new already exists it is truncated and rewritten, otherwise it is made to exist. The new file is an exact replica of the old. .EG To make a backup copy of a precious file: .Q1 makecopy precious backup .Q2 .BU Copying a file onto itself is very system dependent and usually disastrous. -h- MAN/open.m 484 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM open open a file for reading or writing .SY .Q1 name : string; fd : filedesc; mode : IOREAD..IOWRITE; fd := open(name, mode); .Q2 .FU .UL open arranges for access to file .UL name with the specified access mode. It returns a file descriptor if the access succeeds, and .UL IOERROR if not. .UL fd may be used in subsequent calls to .UL getcf, .UL getline , .UL putcf , .UL putstr , etc. -h- MAN/overstrike.m 897 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM overstrike replace overstrikes by multiple lines .SY .UL "overstrike" .FU .UL overstrike copies its input to its output, replacing lines containing backspaces by multiple lines that overstrike to print the same as the input, but contain no backspaces. It is assumed that the output is to be printed on a device that takes the first character of each line as a carriage control; a blank carriage control causes normal space before print, while a plus sign .UL + ' ` suppresses space before print and hence causes the remainder of the line to overstrike the previous line. .EG Using .UL \(<- as a visible backspace: .Q1 overstrike abc\(<-\(<-\(<-___ .S " abc" .S "+___" .Q2 .BU .UL overstrike is naive about vertical motions and non-printing characters. .br It produces one overstruck line for each sequence of backspaces. -h- MAN/print.m 729 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM print print files with headings .SY .UL "print [ file ... ]" .FU .UL print copies each of its argument files in turn to its output, inserting page headers and footers and filling the last page of each file to full length. A header consists of two blank lines, a line giving the filename and page number, and two more blank lines; a footer consists of two blank lines. Pages for each file are numbered starting at one. If no arguments are specified, .UL print prints its standard input; the file name is null. .IP The text of each file is unmodified \(em no attempt is made to fold long lines or expand tabs to spaces. .EG .Q1 print print.p fprint.p .Q2 -h- MAN/putc.m 601 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM putc,\ putcf put one character on output .SY .Q1 c : character; fd : filedesc; putc(c); putcf(c, fd); .Q2 .FU .UL putc and .UL putcf output a single .UL character onto .UL STDOUT or the named file descriptor respectively. .UL NEWLINE is converted into an appropriate action by calling .UL writeln or its logical equivalent. .BU There is no explicit error mechanism. .br The behavior of .UL putc and .UL putcf is undefined if the converted value of .UL c is not a character in the standard character set. -h- MAN/putstr.m 470 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM putstr put a string on a file .SY .Q1 s : string; fd : filedesc; putstr(s, fd); .Q2 .FU .UL putstr puts the string .UL s on the specified file descriptor. .IP .UL putstr and .UL putcf calls may be interleaved. .BU There is no explicit error mechanism. .br The behavior of .UL putstr is undefined if the converted value of any character is not in the standard character set. -h- MAN/remove.m 298 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM remove remove file from secondary storage .SY .Q1 name : string; remove(name); .Q2 .FU .UL remove removes the named file from secondary storage, thus making the name and space available for another use. -h- MAN/seek.m 450 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .ds n PRIMITIVE .NM seek position file for reading or writing .SY .Q1 pos : integer; fd : filedesc; seek(pos, fd); .Q2 .FU .UL seek arranges that the next input-output operation that uses .UL fd will affect the file at the position specified by .UL pos . .BU The units for .UL pos are not specified. In particular, characters and records both have things to recommend them. -h- MAN/sort.m 683 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM sort sort text lines .SY .UL "sort" .FU .UL sort sorts its input into ascending lexicographic order. Two lines are in order if they are identical or if the leftmost character position in which they differ contains characters which are in order, using the internal numeric representation of the characters. If a line is a proper prefix of another line, it precedes that line in sort order. .IP .UL sort writes intermediate data to files named .UL stemp #, where # is a small decimal digit string; these filenames should be avoided. .EG To print the sorted output of a program: .Q1 program | sort | print .Q2 -h- MAN/translit.m 1669 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM translit transliterate characters .SY .UL "translit [^]src [dest]" .FU .UL translit maps its input, on a character by character basis, and writes the translated version to its output. In the simplest case, each character in the argument .UL src is translated to the corresponding character in the argument .UL dest ; all other characters are copied as is. Both .UL src and .UL dest may contain substrings of the form .IT c1-c2 as shorthand for all of the characters in the range .IT c1..c2 . .IT c1 and .IT c2 must both be digits, or both be letters of the same case. .IP If .UL dest is absent, all characters represented by .UL src are deleted. Otherwise, if .UL dest is shorter than .UL src , all characters in .UL src that would map to or beyond the last character in .UL dest are mapped to the last character in .UL dest ; moreover adjacent instances of such characters in the input are represented in the output by a single instance of the last character in .UL dest . Thus .Q1 translit 0-9 9 .Q2 converts each string of digits to the single digit .UL 9 . .IP Finally, if .UL src is preceded by a .UL ^ , then .ul all but the characters represented by .UL src are taken as the source string; i.e., they are all deleted if .UL dest is absent, or they are all collapsed if the last character in .UL dest is present. .EG To convert upper case to lower: .Q1 translit A-Z a-z .Q2 .IP To discard punctuation and isolate words by spaces on each line: .Q1 translit ^a-zA-Z@n " " This is a simple-minded test, i.e., a test of translit. .S "This is a simple minded test i e a test of translit" .Q2 -h- MAN/unique.m 484 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM unique delete adjacent duplicate lines .SY .UL "unique" .FU .UL unique writes to its output only the first line from each group of adjacent identical input lines. It is most useful for text that has been sorted to bring identical lines together; in this case it passes through only unique instances of input lines. .EG To eliminate duplicate lines in the output of a program: .Q1 program | sort | unique .Q2 -h- MAN/unrotate.m 1035 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM unrotate format lines for KWIC index .SY .UL "unrotate" .FU .UL unrotate reads its input a line at a time and writes an ``unfolded'' version to its output. A line is ``folded'' if it contains within it an instance of the fold character .UL $ ; ``unfolding'' involves writing from the end of the line down to but not including the fold character, starting in column 39 of the output line, wrapping characters that would thus appear before column 1 around to the end of the line, then writing the remainder of the line starting at column 41 and wrapping around at column 80 if necessary. .IP .UL unrotate is used with .UL kwic and .UL sort to produce a KeyWord In Context, or KWIC, index. .EG .Q1 unrotate a test.$This is is a test.$This test.$This is a This is a test.$ .S " This is a test." .S " This is a test." .S " This is a test." .S " test. This is a" .Q2 -h- MAN/wordcount.m 423 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM wordcount count words in input .SY .UL wordcount .FU .UL wordcount counts the words in its input and writes the total as a line of text to the output. A ``word'' is a maximal sequence of characters not containing a blank or tab or newline. .EG .Q1 wordcount A single line of input. .S 5 .Q2 .BU The definition of ``word'' is simplistic. -h- PMAN/close.m 280 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM close close a file descriptor .SY .UL "procedure close (fd : filedesc);" .FU .UL close releases the file descriptor and any associated resources for a file opened by .UL open or .UL create . .RE Nothing. -h- PMAN/create.m 943 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM create make a new instance of a file available .SY .UL "function create (name : string; mode : integer) : filedesc;" .FU .UL create makes the file with external name .UL name available for the type of access specified by .UL mode , by placing it under control of a file descriptor. If the file already exists, it is truncated to zero length, otherwise it is introduced as a new zero length file. In general, the only sensible value of .UL mode is .UL IOWRITE , for write access. .IP The file remains under control of the file descriptor returned until explicitly disconnected by a .UL close call, or until the program terminates. .RE .UL create returns .UL IOERROR if the file cannot be accessed as desired, for any reason; otherwise it returns a value of type .UL filedesc suitable for use with subsequent calls to .UL close , .UL putcf , .UL putstr , or .UL seek . -h- PMAN/error.m 364 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM error print a message and exit .SY .UL "procedure error ('your message here');" .FU .UL error writes the literal string specified to a highly visible place, such as the user's terminal, then performs an abnormal exit. .RE Nothing. Moreover, .UL error never returns control to its caller. -h- PMAN/getarg.m 557 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM getarg get a command line argument .SY .UL "function getarg (n : integer; var str : string; maxsize : integer)" .br .UL " : boolean;" .FU .UL getarg writes up to .UL maxsize characters (including an .UL ENDSTR ) of the .UL n th command line argument into the string .UL str . The first argument on the command line is argument number one. No error is reported if the argument string is truncated. .RE .UL getarg returns .UL true if the argument is present, otherwise .UL false . -h- PMAN/getc.m 722 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM getc get a character from standard input .SY .UL "function getc (var c : character) : character;" .FU .UL getc reads at most one character from the standard input .UL STDIN . If there are no more characters available, .UL getc returns .UL ENDFILE ; if the input is at end-of-line, it returns .UL NEWLINE and advances to the beginning of the next line; otherwise it returns the next input character. .RE .UL getc returns the value of type .UL character corresponding to the character read from the standard input, or one of the special values .UL NEWLINE or .UL ENDFILE as specified above. The return value is also written in the argument .UL c . -h- PMAN/getcf.m 776 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM getcf get a character from a file .SY .UL "function getcf (var c : character; fd : filedesc) : character;" .FU .UL getcf reads at most one character from the file specified by the file descriptor .UL fd . If there are no more characters available, .UL getcf returns .UL ENDFILE ; if the input is at end-of-line, it returns .UL NEWLINE and advances to the beginning of the next line; otherwise it returns the next input character and points past it in the file. .RE .UL getcf returns the value of type .UL character corresponding to the character read from the file, or one of the special values .UL NEWLINE or .UL ENDFILE as specified above. The return value is also written in the argument .UL c . -h- PMAN/getline.m 701 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM getline get a line of text from a file .SY .UL "function getline (var str : string; fd : filedesc;" .br .UL " maxsize : integer) : boolean;" .FU .UL getline reads at most one line of text from the file specified by file descriptor .UL fd . The characters are written into .UL str up to and including the terminating .UL NEWLINE ; an .UL ENDSTR is then appended to the input text. No more than .UL maxsize- 1 characters are returned, so a line of length .UL maxsize- 1 that does not end with .UL NEWLINE has been truncated. .RE .UL getline returns .UL true if a line is successfully obtained; .UL false implies end of file. -h- PMAN/message.m 311 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM message print a message and continue .SY .UL "procedure message ('your message here');" .FU .UL message writes the literal string specified to a highly visible place, such as the user's terminal, then continues execution. .RE Nothing. -h- PMAN/nargs.m 411 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM nargs get number of command line arguments .SY .UL "function nargs : integer;" .FU .UL nargs determines the number of arguments used on the command line that invoked the program, suitable for copying by .UL getarg . .RE .UL nargs returns the number of arguments found on the command line, i.e., a number greater than or equal to zero. -h- PMAN/open.m 972 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM open make a file available for input or output .SY .UL "function open (name : string; mode : integer) : filedesc;" .FU .UL open makes the file with external name .UL name available for the type of access specified by .UL mode . Legitimate values of .UL mode are .UL IOREAD for read access and .UL IOWRITE for write access. No other values are currently defined. In either case, the file is not modified by the .UL open call, and access commences with the first character of the file. .IP The file remains associated with the file descriptor returned until explicitly disconnected by a .UL close call, or until the program terminates. .RE .UL open returns .UL IOERROR if the file cannot be accessed as desired, for any reason; otherwise it returns a value of type .UL filedesc suitable for use with subsequent calls to .UL close , .UL getcf , .UL getline , .UL putcf , .UL putstr , or .UL seek . -h- PMAN/putc.m 350 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM putc put a character on standard output .SY .UL "procedure putc (c : character);" .FU .UL putc writes the character .UL c to the standard output .UL STDOUT ; if the value of the argument .UL c is .UL NEWLINE , an appropriate end-of-line condition is generated. .RE Nothing. -h- PMAN/putcf.m 360 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM putcf put a character in a file .SY .UL "procedure putcf (c : character; fd : filedesc);" .FU .UL putcf writes the character .UL c to the file specified by file descriptor .UL fd ; if the value of .UL c is .UL NEWLINE , an appropriate end-of-line condition is generated. .RE Nothing. -h- PMAN/putstr.m 431 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM putstr put string in a file .SY .UL "procedure putstr (var str : string; fd : filedesc);" .FU .UL putstr writes the characters in .UL str , up to but not including the terminating .UL ENDSTR , to the file specified by file descriptor .UL fd . An unsuccessful write may or may not cause a warning message or early termination of the program. .RE Nothing. -h- PMAN/remove.m 493 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM remove remove a file .SY .UL "procedure remove (name : string);" .FU .UL remove causes the file with external name .UL name to be discarded, i.e., a subsequent call to .UL open with the same name will fail and a subsequent .UL create will be obliged to make a new instance of the file. In general, the file to be removed should not be connected to any file descriptor at the time of the .UL remove call. .RE Nothing. -h- PMAN/seek.m 651 { Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. } .NM seek position file access pointer .SY .UL "procedure seek (recno : integer; fd : filedesc);" .FU .UL seek positions the file controlled by .UL fd so that a subsequent .UL read or .UL write call will access the record whose ordinal number is .UL recno . Records are presumed to be of type .UL string ; the first record is number one. .RE Nothing. .BU Our version of this primitive is far from general, having been written just to satisfy the needs of one form of the program .UL edit . It assumes a system that can support simultaneous read and write access to the same file.