PDP-10.its/src/digest/digest.184

; -*- Midas -*-

title DIGEST

a=:1
b=:2
c=:3
d=:4
e=:5
in=:6		; Current input
out=:7		; Current output

t=:10
tt=:11
x=:12
y=:13
z=:14

p=:17

$version==:.ifvrs

..bch==:0,,-1
chdfsi==:1			; DEFS file input
chlogo==:2			; LOG file output
chlock==:3			; LOCK device channel
chibxi==:4			; Inbox input
chibxo==:5			; Inbox output
chrec==:6			; Record file channel
chadmi==:7			; Administrivia file input
chdigo==:10			; Digest output
cherri==:11			; ERR: input for FORMAT

%fr==:0,,525252
%fl==:1,,525252
%flurk==:200000			; Inbox didn't fit in core
%fladm==:100000			; Administrivia feature
%flnpr==:040000			; Not Prime Time
%flwai==:020000			; Digest sent less than C(WAITIM) mins ago
%fldla==:010000			; Need to delete administrivia file

call=:pushj p,
return=:popj p,
save==:push p,
rest==:pop p,
pause=:.break 16,100000
slose=:.lose %lssys

define bltdup org,len
	move tt,[<org>,,<org>+1]
	blt tt,<org>+<len>-1
termin

define syscall name,args
	.call [setz ? .1stwd sixbit /name/ ? args(400000)]
termin

define conc foo,bar
foo!bar!termin

define fall sym
if2, ifn .-<sym>, .err Can't fall into sym?
termin

popj1:	aos (p)
cpopj:	return

rfn"$$rfn==:1
rfn"rsixtp==:cpopj
rfn"$$ruc==:1
rfn"$$pfn==:1
rfn"psixtp==:cpopj
.insrt dsk:syseng;rfn >

datime"$$abs==:1
datime"$$out==:1
datime"$$outz==:1
datime"$$rfc==:1
.insrt dsk:syseng;datime >

format"$$time==:1
format"datime==:datime"timrfc	; ~Q
format"time==:datime"twdasc	; ~:Q
format"date==:datime"timrfc	; ~@Q
format"$$pfn==:1
format"pfn==:rfn"pfn
format"$$errs==:1
format"erri==:cherri
.insrt dsk:syseng;format >

format"defop "Z,op.Z		; Don't try this at home kids...

op.Z:	format"nextarg a
	jumpge e,op.Z4
	move a,sy.idx(a)
	move a,asym(a)
	dmove a,sy.ptr(a)
	call op.Z0
	movei c,":
	format"tyo c
	movei c,40
	format"tyo c
	format"getarg a
op.Z4:	dmove a,sy.ptr(a)
	call op.Z0
	jrst format"loop

op.Z0:	jumple b,op.Z3
	ldb c,a
	jrst op.Z2

op.Z1:	ildb c,a
op.Z2:	format"tyo c
	sojg b,op.Z1
op.Z3:	return

define format &string&,args,ioloc,type=[$format]
	call [
	call type
.zzz.==-1
irp arg,,[args]
	save arg
.zzz.==.irpcnt
termin
	hrroi a,[ascii string]
	movei b,.length string
	movni c,.zzz.+1
ifnb ioloc,[ movei out,ioloc ]
	jrst format"format]
termin

$forma:	save a
	save b
	save c
	save out
	call @-4(p)
	rest out
	rest c
	rest b
	rest a
	rest (p)
	return

define princ &string&
	call [
	call $princ
	<.length string>,,[ascii string]
	]
termin

$princ:	exch a,(p)
	save b
	hlrz b,(a)
	hrrz a,(a)
	hrli a,440700
	call outstr
	rest b
	rest a
	return

define report &string&,args
format string,[args][logo][$report]
termin

$report==:$format

define die &string&,args
format string,[args][logo][$die]
termin

$die:	report "~2&Fatal error:  "
	call @(p)
	move t,-1(p)
	movei t,-2(t)
	report "~&PC/ ~:H",[t]
	jrst quit

define barf &string&,args
format string,[args][logo][$barf]
termin

$barf:	report "~&Error:  "
	call @(p)
	move t,-1(p)
	movei t,-2(t)
	report "~&Aborting.  (PC/ ~:H)",[t]
	jrst abort

; JSP T,LOSE with error code in TT
lose:	trne tt,-100		.see iocint
	 jrst losioc
	syscall lose,[movei %lssys(tt) ? movei -2(t)]
	 slose

losioc:	syscall lose,[movei 1+<.lz %piioc> ? movei -2(t)]
	 slose

edie:	save t
	call $die
	report "~:@E.~%",[tt]
	return

fdie:	save t
	call $die
	report "~F  --  ~:E.~%",[t,b,tt]
	return

ebarf:	save t
	call $barf
	report "~:@E.",[tt]
	return

fbarf:	save t
	call $barf
	report "~F  --  ~:E.",[b,tt]
	return

; Format of IO block:
..bio==:0,,-1
io.bp==:0	; Byte pointer into buffer
io.bc==:1	; Count of available input or space
io.cal==:2	; Routine to put or get next buffer
io.pos==:3	; Position (plus IO.BC)
io.ibp==:4	; Initial IO.BP
io.ibc==:5	; Initial IO.BC
io.chn==:6	; Channel, or other argument to buffer routine
io.buf==:7	; Buffer aobjn, or ""
io.sta==:8	; Status, or ""
io.siz==:9	; Size of this structure

; In the following macros, LOC can be indexed, but not indirect.

define ioout ac,loc=[(out)]
	<idpb ac,loc>+io.bp
	<sosg loc>+io.bc
	 <call loc>+io.cal
termin

define ioflush loc=[(out)]
	<call loc>+io.cal
termin

define ioin ac,eofcod=[...],loc=[(in)]
	<sosge loc>+io.bc
	 call [ <call loc>+io.cal ? eofcod ]
	<ildb ac,loc>+io.bp
termin

define iopos ac,loc=[...]
	<move ac,loc>+io.pos
	<sub ac,loc>+io.bc
termin

; CALL CHCOPY:  Stream to channel copy until EOF
; .+1:  Error code in TT
; .+2:  Normal
; IN (a/v):  Address of input IO block
; A (a/v):  Unit output channel
chcopy:	syscall siot,[moves tt ? movei (a) ? move io.bp(in) ? move io.bc(in)]
	 return
	save [chcopy+2]
	call io.cal(in)		; No, you cannot JRST IO.CAL(IN)
	aos (p)
	return

; CALL IOCOPY:  Stream to stream copy until EOF
; IN (a/v):  Address of input IO block
; OUT (a/v):  Address of output IO block
iocopy:	save a
	save b
iocpy0:	move a,io.bp(in)
	move b,io.bc(in)
	call outstr
	save [iocpy0+2]
	call io.cal(in)
	rest b
	rest a
	return

; CALL OUTSTR:  Output a string
; A (arg):  Byte pointer
; B (arg):  Byte count
; OUT (a/v):  Address of output IO block
outst4:	sub b,io.bc(out)
	call outst7
	movn b,io.bc(out)
	setzm io.bc(out)
	call io.cal(out)
outstr:	movn b,b
	addm b,io.bc(out)
	skipg io.bc(out)
	 jrst outst4
outst7:	jumpge b,cpopj
	save t
outst8:	ildb t,a
	idpb t,io.bp(out)
	aojl b,outst8
	rest t
	return

; CALL OPENO:  Open buffered output stream
; A (a/v):  Channel in RH, opened in unit output mode
; C (arg):  Aobjn to buffer
; OUT (a/v):  Address of IO block
openo:	hrrzm a,io.chn(out)
	movei t,(c)
	hrli t,440700
	movem t,io.ibp(out)
	movem t,io.bp(out)
	hlro t,c
	imul t,[-5]
	movem t,io.ibc(out)
	movem t,io.bc(out)
	movem t,io.pos(out)
	move t,[call ocall]
	movem t,io.cal(out)
	return

; OCALL:  Buffer routine for buffered unit output stream
ocall:	exch out,(p) ? save x ? save y ? save t ? save tt
	movei out,-<1+io.cal>(out)
	move y,io.ibc(out)
	sub y,io.bc(out)
	jumpe y,ocallx
	movn t,io.bc(out)
	addm t,io.pos(out)
	move t,io.ibc(out)
	addm t,io.pos(out)
	movem t,io.bc(out)
	move x,io.ibp(out)
	movem x,io.bp(out)
	syscall siot,[moves tt ? move io.chn(out) ? move x ? move y]
	 jsp t,[ cain out,logo
		  jrst lose
		 jrst ebarf ]
ocallx:	rest tt ? rest t ? rest y ? rest x ? rest out
	return

; CALL OPENI:  Open buffered input stream
; A (a/v):  Channel in RH, opened in block ascii input mode
; C (arg):  Aobjn to buffer
; IN (a/v):  Address of IO block
openi:	hrrzm a,io.chn(in)
	movei t,(c)
	hrli t,440700
	movem t,io.ibp(in)
	move x,c
	aobjn c,.+2
	 .lose
	movem c,io.buf(in)
	hlro t,c
	imul t,[-5]
	movem t,io.ibc(in)
	setzm io.pos(in)
	move t,[call icall]
	movem t,io.cal(in)
	save [-1] ? save in ? save x ? save t ? save tt
	jrst icall0

; ICALL: Buffer routine for buffered block ascii input stream
icall:	exch in,(p) ? save x ? save t ? save tt
repeat 2, sos -5(p)
	movei in,-<1+io.cal>(in)
	skipge t,io.sta(in)
	 jrst icalle
	move x,io.buf(in)
	move tt,-1(t)
	movem tt,-1(x)
icall0:	syscall iot,[moves tt ? move io.chn(in) ? move x]
	 jsp t,edie
	movem x,io.sta(in)
	jumpl x,icall9
	move x,io.ibc(in)
icallx:	movem x,io.bc(in)
	addm x,io.pos(in)
	move tt,io.ibp(in)
	movem tt,io.bp(in)
	rest tt ? rest t ? rest x ? rest in ? rest (p)
	return

icall9:	move t,-1(x)
	sub x,io.buf(in)
	movei x,(x)
	imuli x,5
	jumpl x,icallf		; Zero length file
	call unpad
	addi x,(t)
	jrst icallx

icalle:	move tt,-4(p)
	movem tt,-5(p)
icallf:	setzi x,
	jrst icallx

; SICALL:  Buffer routine for string input stream
sicall:	exch in,(p)
	setzm io.bc-<1+io.cal>(in)
	rest in
	rest -1(p)
	return

; SOCALL:  Buffer routine for string output stream
socall:	save t
	save tt
	movei tt,%enrbf
	 jsp t,edie

; JSP T,WOTSTR:  With output to string
; X (arg):  Length of string to allocate
; OUT (val):  Address of stack allocated IO block
wotstr:	save [440700,,0]	; IO.BP
	save x			; IO.BC
	save [call socall]	; IO.CAL
	save x			; IO.POS
	save [350700,,0]
	save out
	save t
	save a
	movei t,4(x)
	idivi t,5
	movei a,(t)
	call alloc
	 jsp t,edie
	hrrm a,-7(p)
	hrrm a,-3(p)
	movei out,-7(p)
	rest a
	return

; JSP T,WOTOUT:  Finish WOTSTR
; A,B (val):  String
; OUT (val):  Restored
wotout:	rest out
	rest a
	rest b
	sub b,-1(p)
	sub p,[3,,3]
	jrst (t)

; CALL MBXLOCK:  Lock a mailbox
; .+1:  Error code in TT
; .+2:  Normal
; B (a/v):  Name block
; See .INFO.;ITS LOCKS
mbxloc:	move x,1(b)
	rot x,1
	add x,2(b)
	rot x,1
	add x,3(b)
	idivi x,777773
	hrli y,(sixbit /MBX/)
	syscall open,[moves tt ? movsi .uao ? movei chlock
			[sixbit /LOCK/] ? move y]
	 return
	aos (p)
	return

; CALL BIGIOT:  Break an IOT into chunks
; .+1:  Error code in TT
; .+2:  Normal
; A (a/v):  Block mode channel in RH
; Z (a/v):  IOT pointer (updated)
; Only clobbers T and TT
; Goddamn IOT system call can't work for more than 32. blocks.  (For more
; than 128. blocks the pointer isn't negative, and some devices even look
; at bits 4.8 and 4.7 as well!)
bigiot:	tlnn z,-1
	 jrst bigio2
bigio1:	move t,z
	tlo t,700000
	syscall iot,[moves tt ? movei (a) ? move t]
	 return
	movei tt,(t)
	subi tt,(z)
	hrli tt,(tt)
	add z,tt
	tlne z,-1
	 jumpge t,bigio1
bigio2:	aos (p)
	return

; And while we're being embarrassed by ITS, there is always this joke:

; CALL UNPAD:  Count the number of characters in the last word in a file.
; T (arg):  Last word
; T (val):  Number of characters (1 - 5)
; Only clobbers TT
unpad:	xor t,[ .byte 7 ? ^C ? ^C ? ^C ? ^C ? ^C ]
	move tt,t
	subi tt,2
	xor t,tt
	jffo t,.+1
	movei t,7(tt)
	idivi t,7
	return

; JSP TT,ACSAVE:  Save A through E, IN and OUT
svpc==:-8	; SVPC(P) is return PC
svac0==:-8	; SVAC0+C(P) is saved value of C
acsave:	save a
	save b
	save c
	save d
	save e
	save in
	save out
	call (tt)
	 caia
	  aos -7(p)
	rest out
	rest in
	rest e
	rest d
	rest c
	rest b
	rest a
	return

; CALL FINAL:  RENMWO, FINISH, CLOSE
; .+1:  Error code in TT
; .+2:  Normal
; A (a/v):  Channel in RH
; B (a/v):  Name block
final:	.call renmwo
	 return
	.call finish
	 jfcl
	.call close
	 jsp t,fdie
	aos (p)
	return

; CALL GOBOPN:  Open a file
; .+1:  Error code in TT
; .+2:  Normal
; A (a/v):  Block input channel in RH
; B (a/v):  Name block
; E (val):  Word count
gobopn:	hrli a,.bai
	.call open
	 return
	adjsp p,4
	movei x,-3(p)
	syscall rfname,[movei (a)
			movem 0(x) ? movem 1(x) ? movem 2(x) ? movem 3(x)]
	 movei x,(b)
	syscall rfdate,[movei (a) ? movem y]
	 caia
	  skipge y
	   setzi y,
	syscall rauth,[movei (a) ? movem z]
	 caia
	  skipn z
	   movsi z,(sixbit /???/)
	syscall fillen,[moves tt ? movei (a) ? movem e]
	 jrst gobop8
	report "~&Reading ~F (~D words, ~:Q, ~S).",[x,e,y,z]
	aos -4(p)
gobop8:	adjsp p,-4
	return

; CALL GOBBLE:  Read an entire ASCII file into core
; .+1:  Error code in TT
; .+2:  File didn't fit
; .+3:  Normal
; A (a/v):  Block input channel in RH
; C (a/v):  Page aobjn to free core (updated)
; E (arg):  Word count
; D (val):  Byte pointer (incremented: 350700,,<addr>)
; E (val):  Byte count
gobble:	move d,c
	lsh d,12		; D: Word aobjn to given memory
	hrloi x,-1(e)
	eqvi x,(d)		; X: Word aobjn for file
	hlro t,d
	movn t,t		; = length of given memory
	camle e,t
	 skipa y,d
	  skipa y,x		; Y: ... rounded down to given memory
	   move e,t		; E: ... rounded down to given memory
	jumpe e,gobbl1		; Don't ask for core you don't need...
	move t,y
	lsh t,-12
	trz t,-400
	tlo t,-400
	syscall corblk,[moves tt ? movei %cbndw
			movei %jself ? move t ? movei %jsnew]
	 return
gobbl1:	move z,y
	call bigiot
	 return
	aos (p)
	movei t,1777(e)
	lsh t,-12
	hrli t,(t)
	add c,t			; Update C
	hrli d,350700		; Convert D into ascii byte pointer
	imuli e,5		; Convert E into character count
	came x,y
	 return
	aos (p)
	jumpe e,cpopj
	move t,-1(z)
	call unpad
	subi e,5
	addi e,(t)
	return

open:	setz ? sixbit /OPEN/
	moves tt
	move a
	move 0(b) ? move 1(b) ? move 2(b) ? setz 3(b)

topen:	setz ? sixbit /OPEN/
	moves tt
	move a
	move 0(b) ? [sixbit /_DGST_/] ? [sixbit /OUTPUT/] ? setz 3(b)

renmwo:	setz ? sixbit /RENMWO/
	moves tt
	movei (a)
	move 1(b)
	setz 2(b)

finish:	setz ? sixbit /FINISH/
	moves tt
	setzi (a)

close:	setz ? sixbit /CLOSE/
	moves tt
	setzi (a)

.vector pdl(lpdl==:100.)

.scalar uname,jname,xuname,xjname,sname

usrvar:	sixbit /OPTION/	? tlo %opint\%opopc
	sixbit /MASK/	? move [%pipdl\%piioc]
	sixbit /UNAME/	? movem uname
	sixbit /JNAME/	? movem jname
	sixbit /XUNAME/	? movem xuname
	sixbit /XJNAME/	? movem xjname
	sixbit /SNAME/	? movem sname
lusrvar==:.-usrvar

its:	sixbit /MC/ ? sixbit /AI/ ? sixbit /ML/ ? sixbit /MD/
nits==:.-its

itsnam:	440700,,[asciz /MC.LCS.MIT.EDU/]
	440700,,[asciz /AI.AI.MIT.EDU/]
	440700,,[asciz /ML.AI.MIT.EDU/]
	440700,,[asciz /MD.LCS.MIT.EDU/]
nits==:.-itsnam

go:	move p,[-lpdl,,pdl-1]
	setzi 0,		; Clear flags
	movei t,heap+lheap
	movem t,heapcor
	move t,[-lusrvar,,usrvar]
	syscall usrvar,[movei %jself ? move t]
	 slose
	skipn debug
	 jrst nodbg
	setom mintim		; Throw caution to the winds
	move x,sname		; But only on my directory
irps foo,,[log,dfs,mai,dig]
	movem x,foo!dir
termin
nodbg:
.scalar date
	syscall rqdate,[movem date]
	 slose
	setoi t,
	camn t,date
	 jrst quit0
	hrrz t,date
	idivi t,2*60.		; T: time of day in minutes
	caml t,bprime
	 camle t,eprime
	  tlo %flnpr
.scalar date6,time6
	.rdatim t,
	movem t,time6
	movem tt,date6
.scalar mach6
	syscall sstatu,[repeat 6,[ ? movem mach6]]
	 slose
.scalar hostz
	move x,mach6
	movsi t,-nits
	came x,its(t)
	 aobjn t,.-1
	skipl t
	 .lose
	move t,itsnam(t)
	movem t,hostz	

.vector logo(io.siz)
.vector logbuf(llogbuf==:200.)

	move a,[%dowov\.uao,,chlogo]
	movei b,logblk
	move c,[-llogbuf,,logbuf]
	movei out,logo
go6:	.call open
	 jsp t,[tlze a,%dowov
		 jrst go6
		cain tt,%efldv
		 jrst quit0	; Don't make trouble...
		cain tt,%efldr
		 jrst quit0	; Send mail to digestifier maintainers?
		jrst lose ]
	tlzn a,%dowov
	 jrst go7
	syscall fillen,[moves tt ? movei (a) ? movem x]
	 jsp t,lose
	caml x,[50.*2000*5]	; 50 blocks
	 jrst go6
	.access chlogo,x
go7:	call openo
	report "Digestifier version ~D running on ~A (~S).~@
		Job: ~S ~S   Date: ~:Q~
		",[versio,hostz,mach6,uname,jname,date]
	tlnn %flnpr
	 report " (Prime Time)"
	movei a,chdfsi
	movei b,dfsblk
	move c,[-npdefs,,pgdefs]
	call gobopn
	 jsp t,fdie
	call gobble
	 jsp t,fdie
	 die "File is too big!"
	jrst gogo

.vector defsd(2)
.scalar deflst

abort:	move p,[-lpdl,,pdl-1]
	syscall delewo,[movei chdigo]
	 jfcl
	.close chdigo,
	syscall delewo,[movei chibxo]
	 jfcl
	jrst next

dlnext:	syscall delewo,[movei chibxi]
	 jsp t,edie
danext:	.close chibxi,
	tlnn %fldla
	 jrst next
	syscall delewo,[movei chadmi]
	 jsp t,edie
	.close chadmi,
next:	.close chibxo,
	.close chlock,
	dmove d,defsd
gogo:	tlz %flurk\%fladm\%flwai\%fldla
	call nxtmsg
	 jrst done
	dmovem d,defsd		; So ABORT skips to next digest
	report "~2& -- Next --"
	call initat
	call rddef
	dmovem d,defsd
	movem a,deflst
gogo1:	jumpe a,goibx
	report "~&~:Z",a
	hrrz a,sy.nxt(a)
	jrst gogo1

done:	report "~2& -- Done --~2&"
quit:	ioflush logo
	.close chlogo,
quit0:	skipe debug
	 pause
	.logout 1,

.vector ibxblk(4)

goibx:	move e,deflst
	movei x,digblk
	move y,[sixbit /INBOX/]
	movei t,atibx
	movei b,ibxblk
	call fname
	 barf "No inbox specified."
	skipn ibxblk+1
	 barf "Illegal inbox name: ~F",[b]
	jrst goadm

.vector admblk(4)

goadm:	move e,deflst
	movei x,ibxblk
	move y,[sixbit /ADMIN/]
	movei t,atadm
	movei b,admblk
	call fname
	 caia
	  tlo %fladm
	jrst gorec

.vector recblk(4)

gorec:	move e,deflst
	movei x,ibxblk
	move y,[sixbit /RECORD/]
	movei t,atrec
	movei b,recblk
	call fname
	 jfcl
	move a,[.bai,,chrec]
	.call open
	 jsp t,gorec5
gorec6:	move x,[-nprec,,pgrec]
	movsi y,(-nprec,,0)
	syscall corblk,[moves tt ? movei %cbndw
			movei %jself ? move x
			movei chrec ? move y]
	 jsp t,fbarf
	syscall dskupd,[moves tt ? movei chrec]
	 jsp t,fbarf
	.close chrec,
	jrst getibx

gorec5:	caie tt,%ensfl
	 jrst fbarf
	report "~&Creating new record file: ~F",[b]
	hrli a,.bao
	.call topen
	 jsp t,fbarf
	move x,[-nprec,,pgrec]
	syscall corblk,[moves tt ? movei 0 ? movei %jself ? move x]
	 jsp t,ebarf
	move x,[-nprec,,pgrec]
	syscall corblk,[moves tt ? movei %cbndw
			movei %jself ? move x
			movei %jsnew]
	 jsp t,ebarf
	setzm rec
	bltdup rec,lrec
	move e,deflst
	movei t,atinum
	call fnum
	 barf "Unspecified or unparsable First-Issue-Number."
	movem x,rcinum
	move z,[-lrec,,rec]
	call bigiot
	 jsp t,fbarf
	call final
	 jsp t,fbarf
	hrli a,.bai
	.call open
	 jsp t,fbarf
	jrst gorec6

.scalar ibxlst

bloat:	<libx*3>/2		; How big an inbox is before we consider it
				; bloated:  1.5 digests.  (Digests are only
				; produced during Prime Time unless the
				; inbox becomes bloated.)
bprime:	2*60.			; "Prime Time" starts at 2AM
eprime:	7*60.			; and ends at 7AM
mintim:	90.			; At least 90 minutes between digests no
				; matter what.
waitim:	18.*60.			; At least 18 hours between digests if the
				; inbox isn't bloated.

getibx:	move a,date
	move b,rcdate
	call datime"timsub
	idivi a,60.		; Get that in minutes
	report "~&Last digest mailed ~D minute~P ago.",[a]
	camg a,mintim
	 jrst [	report "~&Too soon for another digest."
		jrst next ]
	camge a,waitim
	 tlo %flwai
	movei a,chibxi
	movei b,ibxblk
	move c,[-npibx,,pgibx]
	call mbxlock
	 jsp t,[caie tt,%enafl
		 jrst ebarf
		report "~&Inbox locked."
		jrst next ]
	call gobopn
	 jsp t,[caie tt,%ensfl
		 jrst fbarf
		report "~&No inbox found."
		jrst next ]
	camge e,bloat		; If the inbox is bloated, or it is
	 tlnn %flnpr\%flwai	; Prime Time and we haven't produced a digest
	  jrst gtibxg		; recently, then go.
	report "~&No digest needed."
	jrst next

gtibxg:	report "~&Reading inbox ..."
	ioflush logo
	call gobble
	 jsp t,fbarf
	 tlo %flurk
	call fstmsg
	 jrst [	tlne %flurk	; This can't ever happen, but...
		 barf "Excessive whitespace in inbox."
		report "~&Inbox is empty."
		jrst dlnext ]
	setzi b,
	call rdmsg
	 jrst [ tlne %flurk
		 barf "Excessively large message in inbox."
		jrst gtibx2 ]
gtibx1:	call cons
	call nxtmsg
	 jrst [ tlne %flurk
		 jrst gtibx4
		jrst gtibx5 ]
	dmovem d,ibxd
	call rdmsg
	 jrst [ tlne %flurk
		 jrst gtibx3
		jrst gtibx2 ]
	jrst gtibx1

gtibx2:	call cons
gtibx5:	call nreverse
	movem a,ibxlst
	jrst godig

.vector ibxd(2)
.vector ibxi(io.siz)
.vector ibxbuf(libxbuf==:1000.)

gtibx4:	dmovem d,ibxd
gtibx3:	call nreverse
	movem a,ibxlst
	report "~&Preparing updated inbox ..."
	ioflush logo
	move a,[.uao,,chibxo]
	movei b,ibxblk
	.call topen
	 jsp t,fbarf
	setoi x,
	adjbp x,ibxd+0
	syscall siot,[moves tt ? movei chibxo ? move x ? move ibxd+1]
	 jsp t,fbarf
	movei a,chibxi
	move c,[-libxbuf,,ibxbuf]
	movei in,ibxi
	call openi
	movei a,chibxo
	call chcopy
	 jsp t,ebarf
	report " done."
	ioflush logo
	jrst godig

.vector digo(io.siz)
.vector digbuf(ldigbuf==:1000.)
.scalar digname
.scalar nmsgs
.scalar sbjlst
.scalar nsubj
.vector admi(io.siz)
.vector admbuf(ladmbuf==:100.)

majsep: 70.			; major separator length
minsep: 30.			; minor separator length
usrsep:	25.			; users are allowed separators this long

godig:	move b,ibxlst
	call length
	movem t,nmsgs
	report "~&~D message~P found in inbox.",[nmsgs]
	move c,ibxlst
	setzm sbjlst
	setzm nsubj
subj1:	hlrz e,(c)
	movei t,atsubj
	call find
	 jrst subj2
	dmove a,sy.ptr(a)
	call sbjtrm
	jumpe b,subj2		; Empty subject fields are worthless
	call intern
	aos sy.sbj(a)
	aos nsubj
	move b,sbjlst
	call memq
	 call cons
	movem b,sbjlst
subj2:	hrrz c,(c)
	jumpn c,subj1
	move b,sbjlst
	call nreverse
	movem a,sbjlst

	move e,deflst
	movei t,atname
	call find
	 barf "No Name specified."
	movem a,digname
	movei t,atsubj
	call dflt
	 format "~Z Digest #~D",[digname,rcinum]
	movei a,chdigo
	move c,[-ldigbuf,,digbuf]
	movei out,digo
	call mopen
	 jsp t,ebarf
	movem e,deflst
	format "~v<~Z Digest #~D~; ~Q~>",[majsep,digname,rcinum,date]
	format "~2&Today's Topics:~%"
	skipn c,sbjlst
	 jrst nosubj
subj9:	hlrz a,(c)
	format "~%        ~Z",[a]
	move t,sy.sbj(a)
	caie t,1
	 format " (~D message~P)",[t]
	hrrz c,(c)
	jumpn c,subj9
nosubj:	move t,nmsgs
	sub t,nsubj
	skipe t
	 format "~%        ~D message~P without subject~P",[t]
	tlnn %fladm
	 jrst noadm
	move a,[.bai,,chadmi]
	movei b,admblk
	.call open
	 jsp t,[cain tt,%ensfl
		 jrst noadm
		jrst fbarf ]
	report "~&Found administrivia file."
	tlo %fldla
	move c,[-ladmbuf,,admbuf]
	movei in,admi
	call openi
	format "~2&Administrivia:~2&"
	call iocopy
noadm:	format "~2&~v<~;-~>~2&",[majsep]
	move a,ibxlst
godig1:	hlrz e,(a)
	call mtype
	format "~2&~v<~;-~>~2&",[minsep]
	hrrz a,(a)
	jumpn a,godig1
	iopos b,digo
	format "End of ~Z Digest",[digname]
	iopos a,digo
	sub a,b
	format "~&~v<~;*~>",[a]

	iopos a,digo
	report "~&Mailing ~Z Digest #~D (~D message~P, ~D characters).~
		",[digname,rcinum,nmsgs,a]
	;; Haven't done anything permanent up to now.  Now we start to do
	;; things that we can't take back:
	aos rcinum
	syscall pgwrit,[movei <rcinum_-12>]
	 jsp t,ebarf
	;; If something goes wrong now, we might skip an issue number
	call mclose
	 jsp t,ebarf
	move t,date
	movem t,rcdate
	;; If something goes wrong now, we might duplicate the contents of
	;; a digest
	tlnn %flurk
	 jrst dlnext	; Usually just go delete inbox
	report "~&Updating inbox."
	movei a,chibxo
	movei b,ibxblk
	call final
	 jsp t,fdie
	jrst danext

; CALL FNUM:  Find and parse a number
; .+1:  Symbol not found or can't parse it
; .+2:  Symbol found and parsed
; E (a/v):  List
; T (arg):  Index to search for
; X (val):  Number
fnum:	jsp tt,acsave
	call find
	 return
	setzi x,
	setoi y,
	adjbp y,sy.ptr(a)
	skipg z,sy.len(a)
	 return
fnum1:	ildb t,y
	move t,chtype(t)
	tlnn t,%ctdig
	 return
	imuli x,10.
	addi x,-"0(t)
	sojg z,fnum1
	aos (p)
	return

; CALL FNAME:  Find and parse a file name
; .+1:  Symbol not found
; .+2:  Symbol found
; E (a/v):  List
; T (arg):  Index to search for
; X (arg):  Default name block
; Y (arg):  Default FN2
; B (a/v):  Name block to fill in
fname:	jsp tt,acsave
	hrli x,(x)
	hrri x,(b)
	blt x,3(b)
	movem y,2(b)
	call find
	 return
	aos (p)
	setoi x,
	adjbp x,sy.ptr(a)
	move y,sy.len(a)
	jrst rfn"rfn

ruc:	sojl y,[ movei a,^C ? return ]
	ildb a,x
	cail a,140
	 subi a,40
	return

; CALL MOPEN:  Start sending mail
; .+1:  Error code in TT
; .+2:  Normal
; A (a/v):  Channel in RH
; C (a/v):  Aobjn to buffer
; E (a/v):  Initial contents list
; OUT (a/v):  Address of IO block
mopen:	jsp tt,acsave
	hrli a,.uao
	movei b,maiblk
	.call topen
	 return
	call openo
	movei t,atdate
	call dflt
	 format "~Q",date
	movei t,atmsid
	call dflt
	 call mkmsid
	movei t,atfrom
	call find
	 jrst rebdrg
	movei t,atauth
	call find
	 jrst rebdrg
	move b,a
	movei t,atrcpt
	call find
	 jrst rebdrg
	format "FROM-PROGRAM:~S~@
		FROM-XUNAME:~S~@
		FROM-UNAME:~S~@
		AUTHOR:~Z~@
		RCPT:~Z~@
		HEADER-FORCE:NULL~@
		REGISTERED:F~@
		TEXT;-1~%",[xjname,xuname,uname,b,a]
	movem e,svac0+e(p)
	aos (p)
	jrst mtype0

rebdrg:	movei tt,%ebdrg
	return

; CALL MTYPE:  Format mail
; .+1:  Error code in TT
; .+2:  Normal
; E (a/v):  Attribute List
mtype:	jsp tt,acsave
mtype0:	jumpe e,mtype5
mtype7:	move t,sy.idx(e)
	caml t,aidx+attext
	 jrst mtype4
	format "~:Z~%",e
	hrrz e,sy.nxt(e)
mtype6:	jumpn e,mtype7
mtype5:	format "~%"
	return

mtype4:	format "~%"
	camn t,aidx+attext
	 format "~Z",e
	return

; CALL MKMSID:  Output a message ID
mkmsid:	.gennum t,
	format "<DIGEST.~D.~S.~S.~D@~A>",[versio,date6,time6,t,hostz]
	return

; CALL MCLOSE:  Finish sending mail
; .+1:  Error code in TT, mail may or may not have been sent
; .+2:  Normal, mail is on it's way!
; OUT (a/v):  Address of IO block
mclose:	jsp tt,acsave
	format "~&"
	ioflush (out)
	hrrz a,io.chn(out)
	movei b,maiblk
	jrst final

; CALL FIND:  Find a symbol in a (sorted) list
; .+1:  None found
; .+2:  Found one
; E (a/v):  List
; T (a/v):  Index to search for (canonicalized)
; A (val):  First symbol found
find:	move t,aidx(t)
	movei a,(e)
	jumpe a,cpopj
find1:	camg t,sy.idx(a)
	 jrst find2
	hrrz a,sy.nxt(a)
	jumpn a,find1
	return

find2:	camn t,sy.idx(a)
	 aos (p)
	return

; CALL INSERT:  Insert a symbol in a sorted list
; A (a/v):  Symbol to insert
; E (a/v):  List (updated)
insert:	move t,sy.idx(a)
	movei x,e
	jrst insrt1

insrt3:	camge t,sy.idx(y)
	 jrst insrt2
	movei x,sy.nxt(y)
insrt1:	hrrz y,(x)
	jumpn y,insrt3
insrt2:	hrrzm y,sy.nxt(a)
	hrrzm a,(x)
	return

; CALL DFLT:  Default
; .+1 (arg):  Instruction to output default value
; .+2:  Return
; E (a/v):  List (updated)
; T (arg):  Index to search for
; A (val):  Symbol found, or newly inserted
; B - E passed to routine
dflt:	call find
	 jrst dflt1
	aos (p)
	return

dflt1:	aos a,(p)
	save b
	save t
	movei x,80.
	jsp t,wotstr
	xct -1(a)
	jsp t,wotout
	save a
	movei a,sy.siz
	call alloc
	 jsp t,edie
	rest sy.ptr(a)
	movem b,sy.len(a)
	rest sy.idx(a)
	rest b
	jrst insert

%ct==:1,,525252

%ctact==:	400000
%cteof==:	200000
%cteom==:	100000
%ctcr==:	040000
%ctlf==:	020000
%cteol==:%ctcr\%ctlf
%ctsp==:	010000
%cttab==:	004000
%cthws==:%ctsp\%cttab
%ctws==:%cthws\%cteol
%ctnpr==:	002000
%ctcol==:	001000
%ctalp==:	000400
%ctdig==:	000200
%ctanm==:%ctalp\%ctdig

define defch ch,-line
loc chtype+ch
	line
termin

chtype:	repeat 200, %ctact\%ctnpr,,.rpcnt
defch 41,	repeat 177-41, 0,,.rpcnt+41
defch "0,	repeat 10., %ctdig,,<.rpcnt+"0>
; STRCMP and STRHSH depend on the CHTYPE entries for upper and lower case
; being identical:
defch "A,	repeat 26., %ctalp,,<.rpcnt+"A>
defch "a,	repeat 26., %ctalp,,<.rpcnt+"A>
defch ^_,	%ctact\%ctnpr\%cteom,,^_
defch ^M,	%ctact\%ctnpr\%ctcr,,^M
defch ^J,	%ctact\%ctnpr\%ctlf,,^J
defch ^I,	%ctact\%ctnpr\%cttab,,^I
defch 40,	%ctact\%ctnpr\%ctsp,,40
defch ":,	%ctact\%ctcol,,":
loc chtype+200

; CALL INCH:  Advance one character
; CALL CRLFCH:  Advance one character, where CRLF counts as one
; CALL RINCH:  Back up one character
; CALL INITCH:  Initialize for parsing (reloads C)
; CALL SETCH:  Move to saved point
; CALL MOVECH:  Move relative to current point
; JSP T,SCAN:  Advance one character, exit to .-1
; C (a/v):  Character (updated)
; D (a/v):  Byte pointer (updated)
; E (a/v):  Byte count (updated)
; T (arg):  Distance (for MOVECH) or old point (for SETCH)
; Only clobbers T and TT
crlfch:	tlne c,%ctcr
	 save [incrl1]
inch:	sojle e,inch9
	ildb c,d
	move c,chtype(c)
	return

incrl1:	tlne c,%ctlf
	 jrst inch
	return

rinch:	skipa t,[-1]
setch:	 subm e,t
movech:	sub e,t
	adjbp t,d
	movem t,d
initch:	jumple e,movch9
	ldb c,d
	move c,chtype(c)
	return

inch9:	ibp d
movch9:	movsi c,%cteof
	return

scan:	sojle e,scan9
	ildb c,d
	move c,chtype(c)
	jrst -2(t)

scan9:	ibp d
	movsi c,%cteof
	jrst -2(t)

; CALL BLANK:  Skip blank lines
; C,D,E as usual
blank:	call initch
	tlne c,%cteol
	 jsp t,scan
	move x,e
	tlne c,%cthws
	 jsp t,scan
	tlne c,%cteol
	 jrst blank
	tlne c,%cteof\%cteom
	 return
	move t,x
	jrst setch

; CALL FIELD:  Pick up a field, and advance to next one
; A,B (val):  Field
; C,D,E as usual
field:	call initch
	dmove a,d
field1:	tlnn c,%cteof\%cteom\%cteol
	 jsp t,scan
	move x,e
	tlne c,%cteof\%cteom
	 jrst field9
	call crlfch
	tlne c,%cthws
	 jrst field1
field9:	sub b,x
	return

; CALL FSTMSG:  Advance to first message
; CALL NXTMSG:  Advance to next message
; .+1:  End of file
; .+2:  Normal (positioned at start of first non-blank line)
; D,E as usual
fstmsg:	save c
	jrst fstms1
	
nxtmsg:	save c
	call initch
	tlnn c,%cteof\%cteom
	 jsp t,scan
nxtms1:	tlne c,%cteof
	 jrst nxtms8
	call inch
fstms1:	call blank
	tlne c,%cteof\%cteom
	 jrst nxtms1
	aos -1(p)
nxtms8:	rest c
	return

; CALL RDDEF:  Parse definition from DEFS file
; A (val): List of attribute cells
; D,E as usual
rddef:	jsp tt,acsave
	movei out,logo
	setzm svac0+a(p)
rddef0:	call blank
	tlne c,%cteof\%cteom
	 jrst rddef9
	tlne c,%cthws
	 jrst rddef1
	call field
	call type
	skipl t,sy.idx(c)
	 camn t,aidx+attext	; TEXT attribute isn't ever legal...
	  jrst rddef3
	call xfield
	jrst rddef0

rddef3:	report |~&Ignoring unknown "~Z" field.|,c
	jrst rddef0

rddef9:	dmovem d,svac0+d(p)
	return

rddef1:	call field
	report |~&Ignoring indented text: "|
rddef2:	call strtrm
	call strtyp
	princ |"|
	jrst rddef0

; CALL RDMSG:  Parse message from mail file
; .+1:  Message ended with EOF
; .+2:  Message ended with EOM
; A (val): List of attribute cells
; D,E as usual
rdmsg:	jsp tt,acsave
	movei out,logo
	setzm svac0+a(p)
	call blank
rdmsg0:	call initch
	tlne c,%cteof\%cteom\%cteol
	 jrst rdmsg7
	call field
	call type
	skipl t,sy.idx(c)
	 caml t,[grtext,,0]	; Only groups before GRTEXT are kept
	  jrst rdmsg0
	call xfield
	jrst rdmsg0

rdmsg7:	call blank
	dmove a,d
	tlne c,%ctws
	 jsp t,scan
	tlne c,%cteof\%cteom
	 jrst rdmsg9
rdmsg8:	tlnn c,%cteof\%cteom\%ctws
	 jsp t,scan
	move x,e
rdmsg5:	tlne c,%cthws
	 jsp t,scan
	tlnn c,%cteof\%cteom\%cteol
	 jrst rdmsg8
	tlnn c,%cteol
	 jrst rdmsg6
	call inch
	came c,chtype+"-
	 jrst rdmsg5
	dmove y,d
	camn c,chtype+"-
	 jsp t,scan
	sub z,e
	movei t,40
	camle z,usrsep
	 dpb t,y
	jrst rdmsg8

rdmsg6:	sub b,x
	move c,asym+attext
	call xfiel0
	call initch
rdmsg9:	dmovem d,svac0+d(p)
	tlnn c,%cteof
	 aos (p)
	return

; Common to RDDEF and RDMSG
xfield:	call strtrm
xfiel0:	dmovem d,svac0+d-1(p)	; & alternate entry point
	dmove d,a		; D,E: String
	movei a,sy.siz
	call alloc
	 jsp t,edie
	dmovem d,sy.ptr(a)
	setzm sy.hsh(a)
	setzm sy.sbj(a)
	move c,sy.idx(c)
	movem c,sy.idx(a)
	movei b,svac0+a-1(p)
	jrst xfiel3

xfiel1:	movei b,sy.nxt(x)
xfiel3:	hrrz x,(b)
	jumpe x,xfiel2
	caml c,sy.idx(x)	; Preserve order!
	 jrst xfiel1
xfiel2:	hrrzm x,sy.nxt(a)
	hrrzm a,(b)
	dmove d,svac0+d-1(p)
	return

; CALL TYPE:  Get the type of a field
; A,B (arg):  Field string
; A,B (val):  Value string
; C (val):  Keyword symbol
type:	save d
	save e
	dmove d,a
	call initch
	tlne c,%ctws
	 jsp tt,scan
	dmove a,d
	tlnn c,%cteof\%ctws\%ctcol
	 jsp t,scan
	sub b,e
	call intern		; A: Keyword symbol
	tlne c,%ctws
	 jsp t,scan
	tlnn c,%ctcol
	 jrst type9
	call inch
	tlne c,%ctws
	 jsp t,scan
type9:	move c,a
	dmove a,d
	rest e
	rest d
	return

..bgr==:1,,-1
grorig==:1
grrsnt==:2
grtext==:3
grdef==:4

define defxattr name,string
defattr [name][string][grorig]
defattr [x!name][ReSent-string][grrsnt]
termin

define irpattr body
define defattr name,string,group=grorig
body
termin

; All RFC822 attributes are here, plus a few other common ones.  I have
; commented out those that I have explicitly decided not to include in
; digests.  Before changing the status of any attribute here, please
; -think- about what you are doing.  Fields that are rare (such as
; "Fonts"), and fields that have high utility (such as "Reply-To") are fine
; to include.  Fields that are both common, and of low utility (such as
; "Received" and "In-Reply-To") are bad to include.  (Minimizing the number
; of fields included is good because some people don't have a tool for
; bursting the digest, and so they have to read all the fields we include!)

; Note that the fields included here are -both- the fields that appear in
; digested messages, and the fields that appear in the headers that we
; produce.  (It wouldn't be hard to change this if necessary.)

; defattr rtrn,Return-Path
; defattr rcvd,Received
defxattr msid,Message-ID
; defxattr inrp,In-Reply-To
; defxattr sup,Supersedes
; defxattr refs,References
; defattr imsg,Included-msgs
; defattr irefs,Included-References
defattr font,Fonts
defattr ctm,Character-Type-Mappings
defxattr date,Date
defxattr from,From
; defxattr send,Sender
defxattr path,Path
defxattr rpto,Reply-To
defxattr to,To
defxattr cc,CC
defxattr fcc,FCC
defxattr bcc,BCC
defxattr subj,Subject
defxattr sum,Summary
defxattr kwds,Keywords
defxattr com,Comments
defattr text,TEXT,grtext
defattr name,Name,grdef
defattr ibx,Inbox,grdef
defattr rec,Record,grdef
defattr adm,Administrivia,grdef
defattr auth,AUTHOR,grdef
defattr rcpt,RCPT,grdef
defattr inum,First-Issue-Number,grdef
termin

.idx.==0
..bat==:0,,-1
irpattr [ at!name==:.idx. ? .idx.==.idx.+1 ]
nattr==:.idx.

aptr:	irpattr [ 350700,,[ascii "string"] ]
nattr==:.-aptr

alen:	irpattr [ .length "string" ]
nattr==:.-alen

aidx:	irpattr [ <group>,,at!name ]

.vector asym(nattr)

; CALL INITAT:  Create initial symbol table entries
initat:	jsp tt,acsave
	movei t,heap+lheap
	movem t,heapptr
	setzm symtab
	bltdup symtab,lsymtab
	movsi e,-nattr
intat1:	move a,aptr(e)
	move b,alen(e)
	call intern
	movem a,asym(e)
	move t,aidx(e)
	movem t,sy.idx(a)
	aobjn e,intat1
	return

.vector symtab(lsymtab==:251.)	; 251 is prime

..bsy==:0,,-1
sy.ptr==:0
sy.len==:1
sy.idx==:2
sy.nxt==:3
sy.sbj==:4
sy.hsh==:5
sy.siz==:6

; CALL INTERN:  Convert string into symbol
; A,B (a/v):  String
; A (val):  Symbol
intern:	jsp tt,acsave
	call strhsh
	move t,c
	idivi t,lsymtab
	skipe d,symtab(tt)
	 jrst intrn2
	movei e,symtab(tt)
intrn3:	movei a,sy.siz
	call alloc
	 jsp t,edie
	move t,svac0+a(p)
	movem t,sy.ptr(a)
	move t,svac0+b(p)
	movem t,sy.len(a)
	setzm sy.sbj(a)
	movem c,sy.hsh(a)
	hrrzm a,(e)
	setzm sy.nxt(a)
	setom sy.idx(a)
	movem a,svac0+a(p)
	return

intrn1:	movei e,sy.nxt(d)
	skipn d,(e)
	 jrst intrn3
intrn2:	came c,sy.hsh(d)
	 jrst intrn1
	dmove x,sy.ptr(d)
	call strcom
	 jrst intrn1
intrn9:	movem d,svac0+a(p)
	return

; CALL STRTRM:  Trim string
; A,B (a/v):  String
strtrm:	save c ? save d ? save e
strtr0:	dmove d,a		; & alternate entry point
	call initch
	tlne c,%ctws
	 jsp t,scan
	dmove a,d
	tlne c,%cteof
	 jrst strtr9
strtr1:	tlnn c,%cteof\%ctws
	 jsp t,scan
	move x,e
	tlne c,%ctws
	 jsp t,scan
	tlnn c,%cteof
	 jrst strtr1
	sub b,x
strtr9:	rest e ? rest d ? rest c
	return

; CALL SBJTRM:  Trim a subject string
; A,B (a/v):  String
sbjtrm:	save c ? save d ? save e
	dmove d,a
	call initch
sbjtr1:	tlne c,%ctws
	 jsp t,scan
	dmove a,d
	came c,chtype+"R
	 jrst strtr0
	call inch
	came c,chtype+"E
	 jrst strtr0
	call inch
	came c,chtype+":
	 jrst strtr0
	call inch
	jrst sbjtr1

; CALL STRTYP:  Type string
; A,B (a/v):  String
strtyp:	jsp tt,acsave
	setoi a,
	adjbp a,svac0+a(p)
	jrst outstr

; CALL STRHSH:  Hash string
; A,B (a/v):  String
; C (val):  Hash (>= 0)
strhsh:	movei c,17.
	dmove x,a
	jumpe y,cpopj
	ldb t,x
	jrst strhs1

strhs2:	ildb t,x
	rot c,7
strhs1:	add c,chtype(t)
	sojg y,strhs2
	tlze c,400000
	 hrri c,9973.(c)
	return

; CALL STRCOM:  Compare strings
; .+1:  Strings differ
; .+2:  Strings match
; A,B (a/v):  String
; X,Y (arg):  String
strcom:	came b,y
	 return
	jumpe y,popj1
	move z,a
	ldb t,z
	ldb tt,x
	jrst strcm1

strcm2:	ildb t,z
	ildb tt,x
strcm1:	move t,chtype(t)
	came t,chtype(tt)
	 return
	sojg y,strcm2
	aos (p)
	return

.scalar heapptr,heapcor

; CALL ALLOC:  Allocate memory from the heap
; .+1:  Error code in TT
; .+2:  Normal
; A (arg):  The number of words desired
; A (val):  Aobjn to allocated block
alloc:	movns t,a
	addb a,heapptr
	camge a,heapcor
	 jrst alloc1
alloc9:	hrli a,(t)
	aos (p)
	return

alloc1:	caige a,heap
	 jrst alloc2
	move x,a
	trz x,1777		; X: new HEAPCOR
	move y,heapcor
	sub y,x
	hrloi y,-1(y)
	eqvi y,(x)
	lsh y,-12
	tlo y,-1_8
	syscall corblk,[moves tt ? movei %cbndw
			movei %jself ? move y ? movei %jsnew]
	 jrst alloc8
	movem x,heapcor
	jrst alloc9

alloc2:	movei tt,%efldv
alloc8:	movn a,t
	addm a,heapptr
	return

; CALL CONS:  Cons
; A (arg):  Car
; B (arg):  Cdr
; B (val):  New cons
cons:	hrli a,(b)
	sos b,heapptr
	camge b,heapcor
	 jrst cons1
	movsm a,(b)
	return

cons1:	aos heapptr
	movs b,a
	movei a,1
	call alloc
	 jsp t,ebarf
	movem b,(a)
	movei b,(a)
	return

; CALL NREVERSE:  Reverse a list
; CALL NRECONC:  Reverse and concatenate a list
; A (arg):  New tail for NRECONC
; B (arg):  List
; A (val):  Reversed list
nrever:	setzi a,
nrecon:	jumpe b,reta
nrecn1:	hrrz t,(b)
	hrrm a,(b)
	jumpe t,retb
	hrrz a,(t)
	hrrm b,(t)
	jumpe a,rett
	hrrz b,(a)
	hrrm t,(a)
	jumpn b,nrecn1
reta:	return

retb:	movei a,(b)
	return

rett:	movei a,(t)
	return

; CALL MEMQ:  Membership test
; .+1:  Not found
; .+2:  Found
; A (a/v):  Element
; B (a/v):  List
memq:	movei x,(b)
	jumpe x,cpopj
memq1:	hlrz t,(x)
	cain t,(a)
	 jrst popj1
	hrrz x,(x)
	jumpn x,memq1
	return

; CALL LENGTH:  Length of a list
; B (a/v):  List
; T (val):  Length
length:	movei x,(b)
	setzi t,
	jumpe x,cpopj
lngth1:	hrrz x,(x)
	aoj t,
	jumpn x,lngth1
	return

intsv0==:t			; Save T
intsv9==:z			; Through Z
intsvn==:intsv9+1-intsv0

intctl==:400000+intsv0_6+intsvn	; control bits
intpc==:-<3+intsvn>		; INTPC(P) is PC before interrupt.
intdf1==:intpc-2		; INTDF1(P) is .DF1 before interrupt.
intdf2==:intpc-1		; INTDF2(P) is .DF2 before interrupt.
intrq1==:intpc-4		; INTRQ1(P) are first word bits.
intrq2==:intpc-3		; INTRQ2(P) are second word bits.
intac0==:intpc+1-intsv0		; INTAC0+C(P) is C before interrupt.

tsint:
loc 42
	-ltsint,,tsint
loc tsint
	intctl,,p
	%piioc ? 0 ? -1 ? -1 ? iocint
ltsint==:.-tsint

dismis:	setz ? sixbit /DISMIS/ ? movsi intctl ? setz p

; IOC interrupt of .CALL with error return argument just fails to skip and
; returns with IOC error number as error code.
iocint:	hrrz x,intpc(p)
	.suset [.rbchn,,y]
	syscall status,[movei (y) ? movem z]
	 slose
	tlnn z,-100		; Better not look like standard error
	 .lose
	move y,(x)
	tlc y,(.call)
	movsi t,(setz)
	tlnn y,-1		; Better be .CALL [ SETZ ? ... ]
	 came t,(y)
	  jrst losint
iocnt2:	move t,2(y)
	tlc t,%clerr
	tlne t,(7^9 @(17))	; Unindexed, direct, error return?
	 aoja y,iocnt1		; Nope, keep looking
	movei t,(t)
	caig t,intsv9
	 caige t,intsv0
	  caia
	   addi t,intac0(p)	; Some locations are on the stack now
	hlrzm z,(t)
	aos intpc(p)
	.call dismis
	 slose

iocnt1:	jumpge t,iocnt2
losint:	;; Dismis interrupt and do .LOSE at interrupting PC.
	move t,intrq1(p)
	jffo t,.+2
	 caia			; So just .LOSE 0
	  addi tt,1
	hrl tt,intpc(p)
	syscall dismis,[movsi intctl ? move p ? move intpc(p)
			move intdf1(p) ? move intdf2(p) ? move tt]
	 slose

cnst0:
constants
repeat <.-cnst0+77>/100, conc cnst,\.rpcnt,=:cnst0+.rpcnt*100

versio:	$version

variables

debug:	0

logblk:	sixbit /DSK/
	sixbit /LOG/
	sixbit />/
logdir:	sixbit /DIGEST/

dfsblk:	sixbit /DSK/
	sixbit /DEFS/
	sixbit />/
dfsdir:	sixbit /DIGEST/

maiblk:	sixbit /DSK/
	sixbit /MAIL/
	sixbit />/
maidir:	sixbit /.BULK./

digblk:	sixbit /DSK/
	0
	sixbit /INBOX/
digdir:	sixbit /COMAIL/

patch::
pat:	block 100.
epatch:	-1			; Make memory exist, end of patch area

pgdefs==:<.+1777>_-12
npdefs==:20.			; Even .MAIL.;NAMES > isn't this big!
defs=:pgdefs_12
ldefs==:npdefs_12

pgibx==:pgdefs+npdefs
npibx==:10.			; Usually makes a 45000. character digest.
ibx=:pgibx_12
libx==:npibx_12

pgheap==:pgibx+npibx
npheap==:10.
heap=:pgheap_12
lheap==:npheap_12

pgrec==:pgheap+npheap
rec=:pgrec_12
rcinum=:rec+1			; Number of next issue
rcdate=:rec+2			; Date of previous issue (or 0 if unknown)
nprec==:2			; Lots of room for expansion
lrec==:nprec_12

pgfree==:pgrec+nprec

ifg pgfree-400, .err Memory bloat!

end go