;;;-*-Midas-*-

TITLE Dissociated Press Device

a=1
b=2
c=3
d=4
e=5
f=6

t=10		;T & TT saved by interrupts
tt=11

ct=16
p=17

call=pushj p,
return=popj p,
jcall==jrst
save=push p,
rest=pop p,

dsk==d
boj==b
tty==t

%fojb==1_17.			;We have a superior, so act as an OJB handler.
;;Next 4 are the open mode.  Must be kept in order!
%fnrf==1_16.			;Don't set the reference date.
%fimg==1_15.			;Image, not ascii.
%fblk==1_14.			;Block, not unit.
%fout==1_13.			;Output, not input.
%fdir==1_12.			;Luser asked for a directory listing.
%fval==1_11.			;BOJ interrupts clear this "valid" bit.
%fiot==1_10.			;Luser last seen in an IOT.
%fsio==1_9			;Luser last seen in a SIOT.
%fhak==1_8			;For directory hack.

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

ifndef reprtp, reprtp==0

define report &msg&
ifn reprtp,[
	call [	call $report
		.length msg
		ascii msg]]
termin

define error &msg&
	call [	call $error
		.length msg
		ascii msg]
termin

pdllen==100.
.vector pdl(pdllen)

go:	move p,[-pdllen,,pdl-1]
goinit:	setzb ct,0		;Clear position and flags.
	move tt,[-4,,[	.roption,,a
			.rsuppr,,b
			.runame,,uname
			.rxuname,,xuname
			]]
	.suset tt
	tlo a,%opint\%opopc
	jumpl b,goset
	tlo a,%opojb
	tro %fojb
	syscall open,[[%tjdis\.uao,,tty] ? [sixbit "tty"]]
	 .lose %lssys
	tlne a,%opddt
	 .value [asciz ""]
	report "Greetings!"
goset:	move tt,[-3,,[	.soption,,a
			.s40addr,,[forty]
			.smsk2,,[1_boj]
			]]
	.suset tt
	jrst begin

.vector args(12.)		;Args returned by JOBCAL go here.

begin:	syscall open,[[10\.bio,,boj] ? [sixbit "boj"]]
	 done			;he went away?
	move tt,[-12.,,args]
	syscall jobcal,[movei boj ? tt ? movem t]
	 done			;he went away?
	tlne t,60000		;close? (Huh?)
	 done
	jrst @.+1(t)
	open			;.open
	opndie			;.iot
	mlink			;mlink
	opndie			;.reset
	opndie			;.rchst
	opndie			;.access
	fdele			;.fdele (delete or rename)
	opndie			;.fdele (renmwo)
	opndie			;.call

mlink:	report "Make link"
	syscall mlink,[%clerr,,a ? [sixbit "dsk"]
			args+1 ? args+2 ? args+3
			args+0 ? args+5 ? args+6]
	 jrst opnerr
onesho:	.call jbrt
	 done			;perhaps he gave up
	done

fdele:	skipe args+0
	 jrst rename
	report "Delete"
	syscall delete,[%clerr,,a ? [sixbit "dsk"]
			args+1 ? args+2 ? args+3]
	 jrst opnerr
	jrst oneshot

rename:	report "Rename"
	syscall rename,[%clerr,,a ? [sixbit "dsk"]
			args+1 ? args+2 ? args+3
			args+0 ? args+5]
	 jrst opnerr
	jrst oneshot

opndie:	error "Unexpected opcode from initial JOBCAL"

;;;Come here with error code in A.
opnerr:	report "Open error"
	hrlz a,a
	syscall jobret,[movei boj ? a]
	 done			;perhaps he punted
	done

.vector fname(4)		;filename
.scalar flen			;It's length in 7-bit bytes, corrected for
				;^C lossage.
.scalar fccct			;Just how many ^C's were there?
.scalar fobyt			;Byte size file was written with.
.scalar folen			;Files length in those bytes.

open:	move tt,args+5		;get open mode
	trne tt,777760		;don't support other funny bits
	 jrst [movei a,%ensmd ? jrst opnerr]
	dpb tt,[.bp %fnrf\%fblk\%fimg\%fout,0]	;set it in flags
	move tt,args+4		;save filename
	movem tt,fname
	move tt,[args+1,,fname+1]
	blt tt,fname+3
	move a,fname+1
	move b,fname+2
	camn a,[sixbit ".file."]	;Check for magic names.
	 came b,[sixbit "(dir)"]
	  skipa
	   tro %fdir
	camn a,[sixbit "m.f.d."]
	 came b,[sixbit "(file)"]
	  skipa
	   tro %fdir
	trne %fdir		;We don't support image mode directories
	 trnn %fimg\%fout	; or output to directories.
	  skipa
	   jrst [movei a,%ensmd ? jrst opnerr]
	trnn %fout
	 jrst iopen		;open for input
oopen:	movei a,%ensio		;open for output
	jrst opnerr		;We don't do output yet.

iopen:	move tt,[.uai,,dsk]
	tlne %fnrf		;Respect reference date if so requested.
	 tlo tt,%donrf
	syscall open,[%clerr,,a ? tt ? [sixbit "dsk"]
			fname+1 ? fname+2 ? fname+3]
	 jrst opnerr
	syscall rfname,[%clerr,,ercode ? movei dsk ? movem tt
			movem fname+1 ? movem fname+2 ? movem fname+3]
	 call lssys		;I don't know about this...
	trne %fdir		;Can't take length of a directory.
	 jrst noflln
	syscall fillen,[%clerr,,ercode ? movei dsk ? movem flen
				movem tt ? movem fobyt ? movem folen]
	 call lssys
	setzm fccct
	move t,fobyt
	cain t,7		;If it was written in 7-bit bytes, length
	 jrst noflln		; must be OK.
	move t,flen
	jumpe t,noflln		;Can't argue with a 0 length file.
	move t,flen
	subi t,4		;check out last 4 characters.
	.access dsk,t
repeat 4,[
	.iot dsk,t
	cain t,3
	 aosa fccct
	  setzm fccct]
	movn t,fccct
	addm t,flen
noflln:	ldb tt,[.bp %fimg\%fblk\%fout,0]
	lsh tt,6
	addi tt,22
	syscall jobsts,[%clerr,,ercode ? movei boj ? tt
			fname ? fname+1 ? fname+2 ? fname+3]
	 call lssys
	syscall rfname,[movei boj ? movem tt ? movem juname ? movem jjname]
	 jfcl			;it was only for debugging.
	trnn %fimg\%fblk
	 jrst [	;;If user is using .UAI mode, then we MUST revert to .UAO
		;;because otherwise there is no place to remember which
		;;character in a word he has read! 
		syscall open,[[10\.uao,,boj] ? [sixbit "boj"]]
		 done			;he gave up?
		jrst .+1]
	.call jbrt
	 done			;He gave up?
	call outinit		;Gotcha!  Can't punt as easily now...
	trnn %fdir
	 jrst dp
dirlp:	.iot dsk,a		;What a pain directories are!
	jumpl a,outeof
	cail a,"A
	 caile a,"Z
	  jrst [cail a,"a
		 caile a,"z
		  trz %fhak
		jrst dirupc]
	troe %fhak
	 addi a,"a-"A
dirupc:	call out
	jrst dirlp

.scalar corlen			;Length adjusted to fit in our address space.

dp:	skipn t,flen		;Zero length files are a pain.
	 jrst outeof
	movem t,corlen
	subi t,1
	idivi t,5*2000
	addi t,1
	caig t,400-fpage	;Grabbing infinite core?
	 jrst dpnurk		;Nope.
	move t,[<1000000-fbase>*5]	;That's fucking big!
	movem t,corlen
	movei t,400-fpage
dpnurk:	imul t,[-1,,0]
	hrri t,fpage
	.access dsk,[0]
	syscall corblk,[%clerr,,ercode ? movei %cbndr
			movei %jself ? t
			movei dsk]
	 call lssys
	move c,flen
	call rndinit		;Initialize random number generator.
	call rndpos
dplp:	movei tt,20.
	call rndnum		;Between 5 and 24. characters in a run.
	addi tt,5
	move t,c		;Where will that put us?
	sub t,tt
	jumple t,dpdone		;Beyond the end?  then finish up.
	sub c,tt		;New count.
	hrrei d,-3(tt)		;Keep count in d.  Zap all but three.
charlp:	jsp t,inwrap
	call out
	sojg d,charlp
	jsp t,inwrap
	move d,a
	call out
	jsp t,inwrap
	move e,a
	call out
	jsp t,inwrap
	move f,a
	call out
	call rndpos
srchlp:	ildb a,inbp
	came a,d
	 sojg b,srchlp
	came a,d
	 jrst [jsp t,wrap ? jrst srchlp]
	sosg b
	 jsp t,wrap
	save b
	save inbp
	jsp t,inwrap
	came a,e
	 jrst nope
	jsp t,inwrap
	came a,f
	 jrst nope
	rest (p)
	rest (p)
	jrst dplp

nope:	rest inbp
	rest b
	jrst srchlp

dpdone:	jumpe c,outeof
	jsp t,inwrap
	call out
	soja c,dpdone

.scalar inbp

rndpos:	move tt,corlen
	call rndnum
	move b,corlen
	sub b,tt
	move t,tt
	idivi t,5
	move tt,(tt)[440700,,fbase ? 350700,,fbase ? 260700,,fbase
			170700,,fbase ? 100700,,fbase]
	add tt,t
	movem tt,inbp
	return

inwrap:	ildb a,inbp
	sojg b,(t)
wrap:	move tt,[440700,,fbase]
	movem tt,inbp
	move b,corlen
	jrst (t)

rndnum:	save tt
	call random
	tlz t,400000
	rest tt
	idiv t,tt
	return

buflen=100.
.vector outbuf(buflen)
.scalar outbp,outct

;;;Call here to output character in A.
out:	idpb a,outbp
	sosle outct
	 return
	call stuf
;;;Call here to initialize output.
outini:	move tt,[440700,,outbuf]
	movem tt,outbp
	movei tt,buflen*5
	movem tt,outct
	return

;;;Jump hear at EOF.
outeof:	movei a,buflen*5
	sub a,outct
	jrst eof

;;;Call this routine whenever the output buffer is full.
stuf:	save a
	trnn %fimg\%fblk
	 jrst stuf7
	report "Stuffing..."
	move a,[-buflen,,outbuf]
	add ct,[400000,,buflen]	;Sign bit means that A contains a
				;correction to the position.
	.iot boj,a
	tlz ct,400000
	rest a
	return

stuf7:	report "Stuffing in 7 bit mode..."
	movei a,buflen*5
	add ct,[400000,,buflen*5]	;Sign bit means that A contains a
					;correction to the position.
	move tt,[440700,,outbuf]
	syscall siot,[%clerr,,ercode ? movei boj ? tt ? a]
	 call lssys
	tlz ct,400000
	rest a
	return

;;;Jump here at end of file.  A should contain the number of characters
;;;left over in the output buffer.
eof:	trnn %fimg\%fblk
	 jrst eof7
	report "EOF"
	idivi a,5
	move tt,[ascii ""]
	dpb tt,(b)[4400,,outbuf(a) ? 3500,,outbuf(a) ? 2600,,outbuf(a)
			1700,,outbuf(a) ? 1000,,outbuf(a)]
	skipe b
	 aos a
	move b,a
	hlri b,400000	
	imul a,[-1,,0]
	hrri a,outbuf
	add ct,b
	.iot boj,a
	tlz ct,400000
	jrst eoflp

eof7:	report "EOF7"
	move b,a
	hrli b,400000
	add ct,b
	move tt,[440700,,outbuf]
	syscall siot,[%clerr,,ercode ? movei boj ? tt ? a]
	 call lssys
	tlz ct,400000
eoflp:	trne %fval		;Do we understand the situation?
	 .hang			;Yep, twiddle thumbs.
	tro %fval		;Set valid flag.
	trnn %fiot\%fsio	;Luser last seen in IOT or SIOT?
	 jrst eoflp		;Nope.  That was fast!
	move a,iot.ct
	tlzn a,400000
	 jrst gotct
	hlre b,iot.a
	trnn %fimg\%fblk
	 movn b,iot.a
	add a,b
gotct:	subm ct,a		;We have given him C(A) words since then.
	hlre b,args+0
	trnn %fblk
	 movn b,args+0
	add a,b
	jumpe a,eoflp		;Which is just what he wanted!
	trnn %fsio		;SIOT and block mode just return.
	 trne %fblk
	  jrst wakeup
	trne %fimg		;.UII gets %piioc if you IOT beyond eof
	 jrst ioceof
	trnn %fval		;Last chance to back out loser!
	 jrst eoflp
	;;Suppose he pclsrs and does a SIOT?  He gets a ^C.
	.iot boj,[-1,,3]
	jrst eoflp

ioceof:	trnn %fval		;Last chance to back out loser!
	 jrst eoflp
	;;Suppose he pclsrs and does a SIOT?  He gets an error anyway.
	syscall jobioc,[%clerr,,ercode ? movei boj ? movei 2]
	 call lssys		;suppose he goes away?
	jrst eoflp

wakeup:	.call jbrt
	 jrst eoflp
	jrst eoflp

rndlen==71.			;Canonical random number generator.
rndoff==35.
.vector rnd(rndlen)
.scalar rnd1,rnd2

;;;Returns a random number in T.  This algorithm is a known winner.
random:	sosge t,rnd1
	 jrst [movei t,rndlen-1 ? movem t,rnd1 ? jrst .+1]
	sosge tt,rnd2
	 jrst [movei tt,rndlen-1 ? movem tt,rnd2 ? jrst .+1]
	move t,rnd(t)
	addb t,rnd(tt)
	return

;;;Call here to initialize random number generator.
rndini:	save a
	movei a,rndoff-1
	movem a,rnd2
	movei a,rndlen-1
	movem a,rnd1
	move tt,[171622221402]
rndilp:	move t,tt		;This initialization algorithm is stolen
	muli t,3125.		; from MacLisp.  There is no reason to
	div t,[377777777741]	; believe that IT is particularly good.
	tlcn a,400000
	 jrst [hrlm tt,rnd(a) ? jrst rndilp]
	hrrm tt,rnd(a)
	sojge a,rndilp
	rest a
	return

intacs==t_6+2			;T and TT saved

tsint:	intacs,,p
	0 ? 1_boj ? 0 ? 1_boj ? bojint
tsintl==.-tsint

bojint:	move tt,[-12.,,args]
	syscall jobcal,[movei boj ? tt ? movem t]
	 jrst disint
	tlne t,60000		;time to close up shop!
	 done
	trz %fiot\%fsio\%fval
	jrst @.+1(t)
	caldie			;.open
	iot			;.iot
	caldie			;mlink
	reset			;.reset
	rchst			;.rchst
	cantdo			;.access
	caldie			;.fdele (delete or rename)
	cantdo			;.fdele (renmwo)
	docall			;.call

.scalar iot.a,iot.ct		;save position at last IOT

iot:	report "IOT"
	tlnn t,%jgsio		;Is this IOT or SIOT?
	 troa %fiot
	 tro %fsio
	movem a,iot.a		;record position
	movem ct,iot.ct
disint:	syscall dismis,[%clerr,,ercode ? %clbit,,intacs ? p]
	 call lssys

reset:	report "RESET"
	.call jbrt
	 jrst disint
	jrst disint

docall:	move t,args+0
	camn t,[sixbit "fillen"]
	 jrst fillen
	camn t,[sixbit "rfdate"]
	 jrst rfdate
	camn t,[sixbit "lnkedp"]
	 jrst lnkedp
	report ".CALL"		;stump
	move tt,args+0
	trne %fojb
	 call 6type
cantdo:	movei tt,%ebddv
	report "Wrong type device"
calerr:	hrlz tt,tt
	syscal jobret,[movei boj ? tt]
	 jrst disint
	jrst disint

caldie:	error "Unexpected opcode from JOBCAL on open channel"

.vector vals(12.)		;JOBRET values typically found here

jbrt:	setz			;Common JOBRET call.
	sixbit "jobret"		;Skips, returns no values.
	movei boj
	setzi 1

jbrtv:	setz			;Another common JOBRET call.
	sixbit "jobret"		;Skips, aobjn pointer to values in TT.
	movei boj
	movei 1
	setz tt

rchst:	report "RCHST"
	move tt,[fname,,vals]
	blt tt,vals+3
	hrrei tt,-1
	movem tt,vals+4
	move tt,[-5,,vals]
	.call jbrtv
	 jrst disint
	jrst disint

rfdate:	report "RFDATE"
	trne %fdir		;Guess what doesn't have a reference date...
	 jrst cantdo
	syscall rfdate,[%clerr,,ercode ? movei dsk ? movem vals+0]
	 call lssys
calrt1:	move tt,[-1,,vals]
	.call jbrtv
	 jrst disint
	jrst disint

lnkedp:	report "LNKEDP"
	setzm vals+0		;We are never a link.
	jrst calrt1

fillen:	report "FILLEN"
	trne %fdir		;Directories don't have a length...
	 jrst cantdo
	move t,flen
	trnn %fimg\%fblk
	 jrst filen7
	idivi t,5
	skipe tt
	 aos t
	skipa tt,[36.]
filen7:	movei tt,7
	movem t,vals+0
	movem tt,vals+1
	move t,fobyt
	movem t,vals+2
	move t,folen
	movem t,vals+3
	move tt,[-4,,vals]
	.call jbrtv
	 jrst disint
	jrst disint

$repor:	trne %fojb
	 jrst repor1
	rest (p)
	return

repor1:	exch t,(p)
	call msg
	rest t
	return

.scalar ercode,losepc

lssys:	exch t,(p)
	subi t,2
	movem t,losepc
	movei t,%lssys
	addm t,ercode
	rest t
	trnn %fojb
	 call crash
	syscall lose,[ercode ? losepc]
	 .lose %lssys

$error:	trnn %fojb
	 call crash
	exch t,(p)
	call msg
	rest t
	rest losepc
	sos losepc
	syscall lose,[movei 0 ? losepc]
	 .lose %lssys

msg:	save tt
	move tt,(t)
	movei t,1(t)
	hrli t,440700
	.iot tty,[^p]
	.iot tty,["A]
	syscall siot,[movei tty ? t ? tt]
	 .lose %lssys
	.iot tty,[^p]
	.iot tty,["A]
	rest tt
	return

6type:	jumpe tt,[.iot tty,["*] ? return]
	save t
6typel:	setzi t,
	lshc t,6
	addi t,40
	.iot tty,t
	jumpn tt,6typel
	rest t
	return

$done:	report "Done."
	.logout			;Only die if toplevel
	.close dsk,
	jfcl
	 .hang

done==call $done

.scalar crashx,uname,xuname,jjname,juname

;;;AAAIIIIEEEEE!!!!!!
crash:	save 0			;PDUMP misses the flags...
	syscall open,[[.uio,,dsk] ? [sixbit "dsk"]
			[sixbit "dpdev"] ? uname ? [sixbit "crash"]]
	 .logout 1,		;Well foo!
	setz crashx
	syscall pdump,[movei %jself ? movei dsk ? crashx]
	 .logout 1,		;???
	.iot dsk,[jrst crashr]
	.iot dsk,[jrst crashr]
	.logout 1,

crashr:	rest 0
	syscall open,[[%tjdis\.uao,,tty] ? [sixbit "tty"]]
	 .lose %lssys
	return

cnstnts:
constants

variables

forty:	0
	0
	-tsintl,,tsint

fpage==:<<.-1>_-12>+1
fbase=:fpage_12

end go