-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 <tools.h>

{ 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 <mustcreate.p>
#include <mustopen.p>

{ 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 <tools.h>

{ 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 <mustcreate.p>
#include <mustopen.p>

{ 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 <chars.h>
#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 <getkbd.p>
#include <getc.p>
#include <getline.p>
#include <putc.p>
#include <getarg.p>
#include <nargs.p>
#include <close.p>
#include <open.p>
#include <remove.p>

{ alias names that collide }
#define close	xclose
#define string	xstring

{ utilities }
#include <addstr.p>
#include <equal.p>
#include <esc.p>
#include <index.p>
#include <isalphanum.p>
#include <isletter.p>
#include <islower.p>
#include <isupper.p>
#include <itoc.p>
#include <length.p>
#include <max.p>
#include <min.p>
#include <ctoi.p>
#include <fcopy.p>
#include <mustcreate.p>
#include <mustopen.p>
#include <putdec.p>

{ command line input and file redirection }
#include <initcmd.p>
-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<line2)) then 
		move := ERR
	else begin
		blkmove(line1, line2, line3);
		if (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.
<ENDFILE>
.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"
<ENDFILE>
.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."
<ENDFILE>
.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);
<ENDFILE>


.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"
<ENDFILE>
-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 <document | sort | unrotate
.Q2
-h- MAN/linecount.m 290
{ Copyright (C) 1981 by Bell Laboratories, Inc., and Whitesmiths Ltd. }
.NM linecount count lines in input
.SY
.UL "linecount"
.FU
.UL linecount
counts the lines in its input and writes the total as a line of
text to the output.
.EG
.Q1
linecount
A single line of input.
<ENDFILE>
.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.$
<ENDFILE>
.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.
<ENDFILE>
.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.
                                                                               