;-*-MIDAS-*-

TITLE NAME DRAGON
versio==.fnam2

a=1
b=2
c=3
d=4
e=5
t=6
tt=7

l=10
n=11
 f=l	;logout times stuff
 g=n	;..
v=12	;uuo handler
w=13
u=14	;user index
i=15	;random index
x=16	;int old
p=17	;pdl ptr


ls1c==1		;channel for LSR1 file.
tyoc==2		;terminal output channel
tybc==3		;tty block output
dkic==4		;channel for reading from disk
rlch==7		;reload channel
ptch==12	;picture channel
utyic==13
utyoc==14
usrich==15	;opening up server telnets

ubpfj==10	;mode bit for USR open to prevent reowning

;random byte pointers

$opcod==331100	;op code in instruction
$acfld==270400	;accumulator field
$ixfld==220400	;idx field

$ercod==220600	;error code for .status

dmneli==10000	;dmnbf type word indicating login
dmnelo==20000	;dmnbf type word indicating logout

ifndef maxdoz,maxdoz==5*60.*60.		;run at least every five minutes
ifndef nredis,nredis==30.*30.		;don't redisplay more often than 30 secs

cior==16


define syscal name,args
	.call [ setz ? sixbit/name/ ? args ((setz))]
termin

;the memory map for this crock

;pages 0 - <usrpag-1>;			the program

;pages usrpag - c(ls2lpg)-1		LSRTAB REF file and HOSTS2 file

;pages c(ls2lpg) - hiporg-1;		dynamically allocated space

;pages hiporg - <tvporg-1>;		absolute its pages

;pages tvporg - <tvporg+tvpgs-1>;	tv buffer pages

;page ttlpag - 				TTLOC file

itspgs==400000/2000		;# ITS pages to map in
tvpgs==10			;# pages in tv buffer (not including console reg)

hiporg==400-itspgs-tvpgs-1	;page # of a origin of high pages
abscor=hiporg*2000
tvporg==hiporg+itspgs		;page # of origin of tv buffer

tvorg==tvporg*2000		;origin of tv buffer in our address space
tvend=<tvporg+tvpgs-1>*2000+1777 ;last wd in buffer: b/w bit and frame start #
ttlpag==400-1

;random facts about the pdp-11

ifndef tv11,tv11==0		;# of pdp-11 hassling ttys
ifndef maxkbd,maxkbd==100	;maximum # of keyboards
mapmsk==574377776000		;$<mapmsk>t; in ddt types out 10-11 interface map entry

ifndef maxtty,maxtty==100	;max # tty's we can handle.
ifndef nontty,nontty==40	;max # lisp machines

loc 41
		pushj p,uuoh
loc 70
forty:		0
		jsr ilopr
		-lintblk,,intblk

loc 100

pat: patch":	block 100

intblk:	p	;our pdl ptr.
	
	%piioc		;ioc errors
	0
	-1#%pipdl#%pimpv	;defer everything but mpv and pdl
	-1
	ioc

	%pipdl		;pdl overflow
	0
	-1#%pimpv		;defer everthing but mpv
	-1
	pov

	%pimpv		;memory protect errors
	0
	-1		;defer everthing
	-1
	mpv
	
	%pirlt		;timer interrupt
	0
	%pirlt		;defer self and all i/o
	-1
	timint		;timer comes last because it's asynchronous.

lintblk=.-intblk


dmnbsz:	0		;size (in words) of dmnbf
dmnbp:	0		;our dmnbf ptr
logcnt:	0		;our login-logout count
tcmxh:	0		;line length of our tty.
tcmxv:	0		;screen height of our tty.
nusers:	0		;# of users we mentioned this time.
sysid:	0		;holds current ITS version syms are good for
debug:	0		;non-zero means run on user's tty instead of T52
nlstty:	0		;number of last sty-type tty (plus one).
nl11ty:	0		;number of last tv tty (plus one).
kbdflg:	0		;address in our address space of table in pdp11
			;containing keyboard and tv numbers of the tv ttys.
beglen:	48.		;# of chars taken up by all but the "console location" field

;define stuff needed to get system symbols
define syms list
	irps sym,,[list]
	squoze 0,sym
sym:	0
termin
termin


	;abscor(u)
usrxtb:	syms [uname:xuname:jname:ttytbl:utmptr:suppro:iochnm:]
lusrtb==.-usrxtb

	;abscor(i)
ixtbl:	syms [ttysts:stysts:ttytyp:ttitm:dmnbf:imsoc3:imsoc4:imphtn:]
lixtbl==.-ixtbl

	;system addresss
sysadr:	syms [time:shutdn:dmnbd:tt11p:]
lsysad==.-sysadr

	;constant syms
cnstb:	syms [nct:nfstty:nsttys:nf11ty:n11tys:lublk:impus:dmnsz:dmnbel:niochn:netdui:netdbo:]
lcnstb==.-cnstb


evaler:	move e,(p)	;pick up two arguments
	addi e,2
	exch e,(p)
	move c,1(e)	;aobjn ptr to syms to define
	move d,0(e)	;value to add into symbol's value
evalup:	move b,(c)	;get squoze for sym
	.eval b,	;get addr for it
	 tdza b,b	;undefined means make all zero
	  add b,d	;otherwise merge addr into it
	aobjp c,evaldn
	movem b,(c)	;store in right place
	aobjn c,evalup	;back for all
evaldn:	popj p,

init:	setz a,
	.call [setz
		sixbit /corblk/
		0,,[%cbred,,0]
		0,,[-1]
		0,,[-itspgs,,hiporg]
		0,,[%jsabs]
		400000,,a]
	 .value 0
	pushj p,evaler
	 abscor(u)
	  -lusrtb,,usrxtb
	pushj p,evaler
	 abscor(i)
	  -lixtbl,,ixtbl
	pushj p,evaler
	 abscor
	  -lsysad,,sysadr
	pushj p,evaler
	 0
	  -lcnstb,,cnstb

	move a,dmnsz	;size of demon buffer
	imul a,dmnbel
	movem a,dmnbsz
	move a,nfstty	;want # of last sty
	add a,nsttys
	movem a,nlstty	;store it (note symbol not an its one)
	move a,nf11ty	;ditto for pdp11 tv's
	add a,n11tys
	movem a,nl11ty	;store (note symbol not an its one)
	move a,nct
	caile a,maxtty
	 jsr die
	pushj p,gttys
	popj p,

name:	.close 1,	;close the channel we were loaded on
	move p,[-lpdl,,pdl-1]
	.suset [.roption,,a]
	tlo a,%opint+%opliv+%opopc
	.suset [.soption,,a]
	move a,[squoze 0,nf11ty]
	.eval a,
	 .value
	caie a,52
	 .value		;TTY # of console free display changed
	.suset [.s40addr,,[forty]]
	.suset [.roption,,a]
	skipe debug
	 setz a,
	tlne a,optddt
	 .value [asciz/5/]	;manual start.
	.suset [.smask,,[%pirlt+%piioc+%pipdl+%pimpv]]
	skipn debug
	 jrst name1
	.open tyoc,[%tjmor+%tjctn+%tjdis+.uao,,'tty]	;Don't do continuation lines
	 .lose %lssys
	.open tybc,[%tjmor+%tjctn+%tjdis+.bao,,'tty]
	 .value
	jrst name2

name1:	.open tyoc,[%tjmor+%tjctn+%tjdis+.uao,,'t52]	;char unit out, disp. mode, no continuation lns
	 .value
	.open tybc,[%tjmor+%tjctn+%tjdis+.bao,,'t52]
	 .value
name2:	.call [	setz ? 'cnsget ? 1000,,tyoc ? 2000,,tcmxv ? 2000,,tcmxh
		2000,,a ? 2000,,a ? setzm a]
	 .value
	.call [setz ? 'sstatu ? repeat 5,[ ? 2000,,a ] ? setzm a]
	 jsr die
	exch a,mname
	.rsysi b,	;get version number of i.t.s.
	exch b,sysid
	camn a,mname
	 came b,sysid	;skip if same as the one syms were int'ld with
	  pushj p,init	;else must re-initialize
	pushj p,LS2MAP	;map in LSR1
	pushj p,clrpts	;clear user name ptrs
	skipl @tt11p	;wait for TV 11 to come up
	 .hang
	pushj p,map11
	move a,@dmnbd	;find our initial dmnbf ptr
	movem a,logcnt
	idiv a,dmnsz
	imul b,dmnbel
	movem b,dmnbp
	jrst lk1

;put all logged in users in our tables
lookup:	move a,[400000,,[0]]
	.realt a,	;stop the timer
	 jfcl
	movei a,1.*30.
	.sleep a,
lk1:	move a,[440700,,screen]
	movem a,sptr
	hrlz i,nct	;length of its tty tables (# of ttys)
	movn i,i	;as aobjn.
	setz x,		;count of users to display
	skipl @tt11p	;check if 11 has died
	 jrst 11upw	;it did, wait for it to be revived

loklup:	move u,@ttysts	;get status wd for this tty
	setzm unmtab(i)
	tlnn u,%tscns	;being used as a console?
	 jrst lokcnt	;no, disregard
	hrres u		;flush lh
	jumpl u,lokcnt
	hrrz a,i	;get tty #
	caml a,nfstty	;is it a psuedo?
	 caml a,nlstty
	  jrst gotdat	;we have all info in u
	sub a,nfstty	;tis a sty...find sty #
	exch i,a	;use i for sty index temporarily
	move u,@stysts	;get sty info (i.e. who has this sty open)
	exch a,i	;restore i
	move a,@uname	;get uname and
	move b,@jname	;jname of controlling procedure.
	movem a,auxtb1(i)
	movem b,auxtb2(i)
	movem u,svrjob(i)
	hrrei n,-1	;if job isn't a server, n will have -1.
	skipl @suppro	;to be a server, must be top level 
	 jrst gotsvx
	came b,['stelnt] ;and jname must be stelnt, netrfc, telser, or rfc<nnn>
	 camn b,['netrfc]
	  jrst gotsv1
	hlrz a,b
	caie a,'log
	 camn b,['telser]
	  jrst gotsv1
	jrst gotsvx

	;hack network server - simply make i not be -1
gotsv1:	movei n,1
gotsvx:	movem n,ttytab(i) ;n has host number if server, else -1.
	hrrz u,@ttysts	;restore u
gotdat:	jumpe u,lokcnt	;don't mention system job.
	move a,@utmptr	;record info in tables
	move a,abscor(a)
	movem a,jtmtab(i)
	move a,@jname
	movem a,jnmtab(i)
	skipa a,u		;find idx no of top level job
gotda1:	 move u,b
	skipl b,@suppro
	 jrst gotda1		;loop till find -1, which means job is top level
	move b,@uname		;get UNAME and XUNAME from top level job.
	movem b,unmtab(i)
	move b,@xuname
	movem b,xuntab(i)
	aos x			;count of users to display
lokcnt:	aobjn i,loklup

;falls through

;drops in

;Get data from Lisp machines.  We use a Chaosnet simple-transaction with contact
;name FINGER.  The first line of the response is the user ID, the second is
;the console location, the third is the idle time (as a string).

;Look through the host table to find all the Lisp machines.
;Contact them eight at a time using all 16 I/O channels.
lmfing:	.iopush tyoc,
	.iopush tybc,
	.iopush ls1c,
	movsi a,-nontty		;Forget all Chaos net users
lmfng0:	setzm unmtab+maxtty(a)
	setzm lmfree(a)
	aobjn a,lmfng0
	setz c,			;C has index into LMADRS.
	movei b,hslmai
lmfin2:	move a,b		;Each word of table is an ASCIZ string.  Get address.
	skipn (a)
	 jrst lmfin3
	push p,b
	push p,c
	pushj p,netwrk"hstlook	;Look it up as a host name.
	 setz a,
	pop p,c
	pop p,b
	skipn a			;If we found one,
	 aoja b,lmfin2
	movem a,lmadrs(c)	;store it in LMADRS.
	addi c,1
	caile c,nontty		;Complain if LMADRS gets full.
	 .value
	aoja b,lmfin2

lmfin3:	setzm nextlm
	.rdtime t,		;Get starting time.  Use at most 20 seconds for whole thing.
	addi t,20.*30.
	movem t,chstim'		;Time to stop
	;Now start 8 RFC's
	movei a,16
lmstr4:	pushj p,lmrfc
	subi a,2
	jumpge a,lmstr4
	;Collect results
lmstr6:	movei a,16		;Scan all the channels
lmstr7:	pushj p,chsin1
	subi a,2
	jumpge a,lmstr7
	movsi a,-8		;See if any channels still active
	skipge chsidx(a)
	 aobjn a,.-1
	jumpge a,lmstr9
	.rdtime t,		;Yes, timed-out anyway?
	caml t,chstim
	 jrst lmstr9
	movei t,60.		;No, delay 2 seconds and try again
	.sleep t,
	jrst lmstr6

lmstr9:	movsi a,-20		;Close channels and return
lmstr8:	.call [ setz ? sixbit/close/ ? setzi (a) ]
	 jfcl
	aobjn a,lmstr8
	.iopop ls1c,
	.iopop tybc,
	.iopop tyoc,
	jrst putout

	;Lisp machines associated with AI.
hslmai:	irps x,,lm1 lm2 lm3 lm4 lm5 lm6 lm7 lm8 lm9 lm15 lm16 lm18 lm19 lm20 lm22 lm23
	   asciz /x/
	termin
	0

;Enter an RFC to next Lisp machine on channel in A.
;Uses AC's a,b,t,tt
lmrfc:	move t,a		;mark channel free
	lsh t,-1
	setom chsidx(t)
	move tt,nextlm		;Find next machine
	caige tt,nontty
	 skipn b,lmadrs(tt)
	  popj p,
	aos nextlm
	movem tt,chsidx(t)
	.rdtime tt,
	movem tt,chsstm(t)
	dpb b,[$cpkda+lmpkt]	;send RFC to this guy
	movei tt,%corfc
	dpb tt,[$cpkop+lmpkt]
	movei tt,.length/FINGER/
	dpb tt,[$cpknb+lmpkt]
	move tt,[.byte 8 ? "F ? "I ? "N ? "G]
	movem tt,%cpkdt+lmpkt
	move tt,[.byte 8 ? "E ? "R]
	movem tt,%cpkdt+1+lmpkt
	.call [ setz ? 'CHAOSO ? movei (a) ? setzi 1(a) ]
	 jrst [	setom chsidx(t) ? popj p, ]	;probably device full
	.call [ setz ? 'PKTIOT ? movei 1(a) ? setzi lmpkt ]
	 jsr die
	popj p,			;pick up answer later

;Call here to check status of channel-pair in a
chsin1:	;set c to index into lisp-machine tables
	move tt,a
	lsh tt,-1
	skipge c,chsidx(tt)
	 popj p,		;channel not in use
	.call [ setz ? 'WHYINT ? movei (a) ? movem b ? movem b ? setzm b ]
	 jsr die
	hlrzs b			;number of input packets
	jumpe b,chsin9		;none yet
	.call [ setz ? 'PKTIOT ? movei (a) ? setzi lmpkt ]	;Get the packet
	 jsr die
	ldb tt,[$cpkop+lmpkt]
	caie tt,%coans
	 jrst lmrfc		;Some lossage, ignore this machine
	;First line is UNAME in ascii
	move b,[440800,,%cpkdt+lmpkt]
	movei d,0
	move tt,[440600,,d]
chsin2:	ildb t,b
	cain t,215
 	 jrst chsin3
	caige t,140
	 subi t,40
	tlne tt,770000
	 idpb t,tt
	jrst chsin2

chsin3:	movem d,unmtab+maxtty(c)
	movem d,xuntab+maxtty(c)
	push p,a
	move a,lmadrs(c)	;Use name of machine as jname
	pushj p,netwrk"hstsix
	 .value
	movem a,jnmtab+maxtty(c)
	pop p,a
	;Second line is console location in ascii
	move e,lmdoc(c)
	movei d,10*5-1		;max characters
chsin4:	ildb t,b
	cain t,215
	 jrst chsin5
	idpb t,e
	sojg d,chsin4
	ildb t,b
	caie t,215
	 jrst .-2
chsin5:	movei t,0		;make sure string is terminated
	idpb t,e
	;Third line is idle time as a string
	movei e,jtmtab+maxtty(c)
	hrli e,440700
	setzm (e)		;make sure string is terminated
	movei d,4
chsin6:	ildb t,b
	cain t,215
	 jrst chsin7
	idpb t,e
	sojg d,chsin6
chsin7:	skipn unmtab+maxtty(c)	;anyone logged-in there?
	 setom lmfree(c)	;no, mark as free
	jrst lmrfc		;find another guy

chsin9:	.rdtime t,
	sub t,chsstm(tt)
	caige t,4*30.
	 popj p,
	jrst lmrfc		;timed out, give up on this guy

;Clear the screen and print initial messages
putout:	movsi i,-maxtty-nontty	;aobjn ptr to all ttys
	iot tyoc,[asciz /C/]
	move d,@shutdn		;get system var saying if/when sys is scheduled to die.
	jumpl d,die2
	jumpe d,putou3		;not scheduled to go down.
	sub d,@time
	idivi d,30.		;it is; d gets # seconds till then.
	.rlpdt a,		;get # seconds from start of year to now.
	add a,d			;get # seconds from start of year till sys goes down.
	idivi a,24.*60.*60.	;remainder is # seconds since midnight.
	iot [asciz /ITS GOING DOWN AT /]
	prt b
	iot [asciz/
/]
	pushj p,gdwnml
	pushj p,pdwnml
	skipa
putou3:	 setzm dwnmlp		;Not going down, discard any previous down mail pointer
	jumpn x,putou1	;possibility of no users...
	iot tyoc,[asciz /No users
/]
	jrst finish

putou1:	iot [asciz /
-User-	  -Full Name-            Jobnam Idle TTY -Console Location-
/]
	setzm nusers
ptolup:	move a,xuntab(i)
	skipn unmtab(i)	;don't mention a tty which has no logged in tree.
	  jrst ptocnt
	aos nusers
	pushj p,unmout	;print info about user (eg his name)
	pushj p,jnmout	;just job name for now
	pushj p,ttyout	;info about tty
ptocn9:	chr [^M]	;new line
	chr [^J]
ptocnt:	aobjn i,ptolup

finish:	iot [asciz /
System up time = /]
	move c,@time
	idivi c,30.		;system up time in seconds
	prh c
	iot [asciz /    Last updated at /]
	.rlpdt c,
	idivi c,24.*60.*60.
	prt d
	pushj p,xgpsts		;display xgp status
	typi ^M			;followed by crlf
	movsi c,-nontty		;See if any Lisp machines free
	skipn lmfree(c)
	 aobjn c,.-1
	jumpge c,[ iot [asciz /No free Lisp machines/]
		   jrst finisd ]
	iot [asciz /Free Lisp machines: /]
	movei e,5		;e controls number per line
	jrst finis1

finis0:	skipn lmfree(c)
	 jrst finis4
	iot [asciz /, /]
	sojg e,finis1
	iot [asciz/
  /]
	movei e,6
finis1:	move b,jnmtab+maxtty(c)	;Give machine name and room number
finis2:	movei a,0
	lshc a,6
	typi 40(a)
	jumpn b,finis2
	typi 40
	move b,lmdoc(c)
finis3:	ildb a,b
	caie a,40
	 jumpn a,[ typi (a)
		   jrst finis3 ]
finis4:	aobjn c,finis0
finisd:	typi ^M			;end with crlf
	movei a,2*30.		;sleep 2 seconds so output
	.sleep a,		;is high priority
	pushj p,ttyfrc		;send out tty buffer and flush it.
	.call [setz ? sixbit /rcpos/ ? movei tyoc ? setzm cposav']
	 jsr reload		;save cursor position for draw routine
	pushj p,bdays		;output birthdays known.
	.rlpdtm c,		;c gets seconds since beginning of year
	idivi c,24.*60.*60.	;d gets seconds since beginning of day
	idivi d,60.*60.		;d gets hour since midnight
	exch d,chour
	came d,chour
	 jrst [ pushj p,rpic	;read in a new picture every hour
		pushj p,clrpts
		pushj p,bdyupd	;and crunch new birthdays.
		jrst .+1 ]
	.call [ setz ? 'rfname ? movei ls1c	;See if need new inquir data base
		movem a ? movem b ? setzm c ]
	 .lose %lssys
	hlrzs c			;RH(C) := First three characters of FN2
	skipe c
	 cain c,'OLD
	  pushj p,ls2map	;Not open, OLD, or OLDOLD => get new
	movei a,2*30.		;sigh, sleep for 2 sec since FLUSH loses on TV.
	.sleep a,
	pushj p,draw


;the reason for sleeping for short intervals of time is to make sure
;that "not in operation" appears, and the demon is logged out,
;no more than slpt1/30 sec after its is down. if demon doesn't log out,
;a salvage will be necessary because shared pages will still have their
;tut entries aos'd.
	skipe @shutdn
	 jrst die1	;it will die soon - check frequently for whether it's down yet.
	movei x,nredis	;its won't die son - just wait the whole interval at once.
	.sleep x,
	move a,[600000,,[maxdoz]]
	.realt a,
	 jfcl
	move a,logcnt	;our count of the no. of logins and logouts
nap1:	camn a,@dmnbd	;their count
hang1:	 .hang
	pushj p,dmngbl
	aosn updtfl
	 jrst lookup
	jrst nap1

dmngbl:	move a,logcnt
	camn a,@dmnbd
	 popj p,
nap0:	move i,dmnbp
	caml i,dmnbsz
	 setz i,
	pushj p,lotprc	;process logout times stuff
	addi i,1	;entry+1 is type word
	move a,@dmnbf
	tlnn a,dmneli+dmnelo
	 jrst nap2
	addi i,2	;entry+3 is jname
	move a,@dmnbf
	camn a,[sixbit /hactrn/]
	 setom updtfl'	;will need to update
nap2:	subi i,3	;this entry wasn't human, ignore it
	add i,dmnbel	;move ptr to next entry
	aos a,logcnt
	movem i,dmnbp	;store the updated ptr
	came a,@dmnbd
	 jrst nap0
	skipn lotupk
	 popj p,
	movns lotupk
	jrst lotprc

die1:	move a,[600000,,[maxdoz/2]]
	.realt a,	;don't forget to update the listing if there is time
	 jfcl
	skiple @shutdn	;wait for the system to actually go down
hang2:	 .hang
	skipl @shutdn
	 jrst lookup	;someone revived the system

die2:	.iot tyoc,[^P]	;come here on determining I.T.S. is down.
	.iot tyoc,["C]
	move a,[440600,,mname]
die3:	ildb b,a
	addi b,40
	.iot tyoc,b
	caie b,40
	 jrst die3
	move a,[-6,,[ascic /ITS not in operation as of /]]
	.iot tybc,a
	.rlpdt c,
	idivi c,24.*60.*60.
	prt d
	.iot tyoc,[^M]
	pushj p,gdwnml		;read and print reason for sys down
	pushj p,pdwnml
	setom lotupk		;do final logout times update
	pushj p,dmngbl
	jsr die

die:	0
	.logout
	.value

;print reason for system down

gdwnml:	skipe dwnmlp
	 popj p,		;already got it, don't try again sys might have deleted file
	move d,[dwnml,,dwnml+1]
	setzm dwnml
	blt d,dwnmz-1
	setzm dwnmlp
	.open dkic,[.bai,,'sys
		     sixbit /down/
		     sixbit /mail/]
	 popj p,
	move d,[dwnml-dwnmz,,dwnml]
	.iot dkic,d
	hrloi d,-dwnml-1(d)
	eqvi d,dwnml
	movem d,dwnmlp
	popj p,

pdwnml:	skipl @shutdn
	 jrst [	iot dwnml
		chr [^M]
		popj p,]
	move d,dwnmlp
	.iot tybc,d	;can't use regular buffering frob
	.iot tyoc,[^M]
	popj p,

rpic:	aos a,cpict		;increment the picture no.
	pushj p,cvnfn		;get sixbit of picture no.
	.call [	setz
		sixbit /open/	;open new picture file
		[.bii,,ptch]
		[sixbit /dsk/]
		[sixbit /nampic/]
		a
		setz [sixbit /channa/]]
	 jrst rp1
	.call [	setz		;find length of picture file
		sixbit /fillen/
		1000,,ptch
		setzm a ]
	 .value
	caile a,455.*18.	;picture larger than our buffer?
	 movei a,455.*18.	;yes, only read in first part
	movem a,pictl		;set length for later
	movsi a,-1(a)		;get .iot block mode arg
	eqvi a,-pictur-1	;...
	.iot ptch,a		;read in file
	.close ptch,
	popj p,
rp1:	move a,cpict
	cain a,1
	 popj p,
	setzm cpict
	jrst rpic

draw:	move b,nusers
	move a,cposav		;get cursor position saved before birthday hacking.
	hlrzs a			;vertical pos in left half
	camg a,b		;vpos less than number of users printed =>
	 popj p,		; we wrapped around, so don't draw picture.
	caml b,tcmxv		;# of users exceeds screen height => we wrapped around.
	 popj p,
	addi a,1		;start pictur on next line
	imuli a,12.*18.		;multiply to get word offset in tv buffer
	movei a,tvorg(a)	;get ptr to place to start picture
	hrli a,pictur		;make a BLT ptr
	move b,pictl		;make ptr to last word to write in buffer
	addi b,-1(a)		;...
	caile b,tvend-1		;if beyond end of buffer then truncate
	 movei b,tvend-1	;...
	blt a,(b)		;draw picture
	popj p,

cvnfn:	move c,[440600,,a]
cvnfn1:	idivi a,10.		;convert a no. to sixbit
	jumpe a,cv1
	push p,b
	pushj p,cvnfn1
	pop p,b
cv1:	movei b,20(b)
	idpb b,c
	popj p,

unmout:	move a,unmtab(i)	;get uname
	move b,a
	pushj p,type6		;type out the sixbit
	chr [40]		;one tab
	exch b,ttyunm(i)	
	move c,ttynmp(i)	;use stored name ptr if any
	move a,grpchr(i)	;and stored group char
	move d,relchr(i)	;along with stored relatio char
	came b,ttyunm(i)
	 pushj p,useek	; not same. look for this uname in dir, copy fullname down ptr in c.
	movem a,grpchr(i)
	cain a,0
	 movei a,"-	;use this if no group char specified.
	movem d,relchr(i)
	cain d,0
	  movei d,40	;just space if no relation char.
;If relation is X, then this is an X-user, so we want to inform the world
;even if the group is A, L, or *.
	cain d,"X
	  jrst prxusr
	cain a,"A	;ignore this since namdrg only runs on AI.
	  jrst praiur
	caie a,"L
	 cain a,"*	;also ignore
;	   jrst praiur	;print relation also for everybody but A, L, and *.
;	jrst prxusr
praiur:	movei a,40
	movei d,40
prxusr:	chr a
	chr d
	chr [40]
	setz d,
	movei b,22.
	jrst typcnt	;type string c points to.
			;return...are now at 8+24 th col.
			;c has b.p. to where we stopped in printing the full name.

;look for uname in XUNTAB(I).  Permute fullname and copy it down
;the b.p. supplied in C.
;A will have the "group designation char" if there is one.
;B gets the core address of the entry, which will be valid only until the next useek.
;If the user has no entry, B gets 0.
;D gets "relation character" if there is one.
useek:	move b,[ascii /     /]	;Init the ttynmp tring in case we don't find an entry.
	movem b,(c)
	move b,[ascii / ???/]
	movem b,1(c)
	move b,xuntab(i)
	hlre a,b		;b gets xuname, or ______ for non-logged-in users.
	aosn a
	 seto b,
useek1:	movei a,ls1c		;a gets channel LSR1 is open on.
	pushj p,lsrtns"lsrunm	;search LSR1 for the uname.
	 jrst usearl		;not found => return standard stuff.
	movei a,lsrtns"i$name
	pushj p,lsrtns"lsritm	;get pointer to full name item.
	 jrst usearl		;every entry ought to have one.
	push p,b
	move b,c
	pushj p,lsrtns"lsrnam	;permute fullname into lastname last order,
	 jsr die		;copying into the ttynmp string.
	pop p,b
	movei a,lsrtns"i$grp	;now get the "Group" item,
	pushj p,lsrtns"lsritm
	 setz a,
	ildb a,a			;and extract its 1st character.
;The below can't (?) happen.
;	cain a,^M
;	 setz a,		;for a null entry return 0.
	push p,a		;save it so we can get the "Relation." into D.
	movei a,lsrtns"i$rel
	pushj p,lsrtns"lsritm
	  setz a,
	ildb a,a
	move d,a
	pop p,a			;restore group to a.
	popj p,

;here if user has no entry or entry has no fullname.
;We come here if user has no fullname but does have group, so
;that's why the free console says something different for
;those people than does :name.  Feature?
usearl:	setzb a,b
	setz d,
	popj p,

typcon:	idpb a,sptr
typcnt:	sojl b,[popj p,]	;this routine takes pointer in c,limit in b.
	ildb a,c	;get char
	cail a,40	;control chr is delimiter
	 jrst typcon
padlup:	chr [40]
	sojl b,[popj p,];output blanks up to limit
	jrst padlup

;jnmout:	chr [^I]	;one tab
jnmout:	chr [40]	;one space
	move a,jnmtab(i)
	jrst type6	;type out 6bit name of job

;print out all info about tty - how long idle, what tty number, and where it is.
ttyout:	chr [40]
	hrrei a,-maxtty(i)
	jumpl a,ttyoun		;jump if not lisp machine
	movei c,jtmtab(i)	;yes, idle time is in ascii
	hrli c,440700		;count chars, wants to fit in 4-column field
	movei a,4
ttyol1:	ildb b,c
	skipe b
	 soja a,ttyol1
	jumpe a,ttyol3
ttyol2:	chr [40]		;put leading spaces
	sojg a,ttyol2
ttyol3:	movei a,jtmtab(i)
	pushj p,typ7ta
	movei a,5
ttyol4:	chr [40]
	sojg a,ttyol4
	move a,lmdoc-maxtty(i)	;Console location
	jrst type7u

ttyoun:	move a,@time
	sub a,@ttitm	;- time of last input on this tty.
	idivi a,30.*60.	;get time in minutes tty has been idle.
	jumpe a,[iot [asciz /    /]
		jrst ttyou1]	;it's been a very short time
	caige a,60.
	 jrst [	chr [40]
		chr [40]
		pushj p,dectyp	;< 1 hr - say how many minutes
		jrst ttyou1]
	idivi a,60.
	cail a,10.
	 jrst [	iot [asciz /*:**/]
		jrst ttyou1]	;a very long time.
	addi a,"0
	idpb a,sptr
	chr [":]
	idivi b,10.
	addi b,"0
	addi c,"0
	idpb b,sptr
	idpb c,sptr
ttyou1:	move a,jtmtab(i)
	jumpn a,[chr [40]
		 jrst ttyou2]
	chr [".]
ttyou2:	hrrz b,i ;get tty number.
	chr ["T]
	ldb a,[030300,,b]
	addi a,"0
	idpb a,sptr	;and print it as "T" followed by 2 digits.
	ldb a,[000300,,b]
	addi a,"0
	idpb a,sptr
	chr [40]
	move tt,tcmxh	;init horizontal position info
	sub tt,beglen
	caml b,nfstty	;a sty?
	 caml b,nlstty
	  caia		;no! skip.
	   jrst hstout	;yes! assumption is net caller.
	caml b,nf11ty	;a pdp11 tv?
	 camle b,nl11ty
	  jrst nrmtty	;nope, 'normal' tty.

;here if its a tv

tv:	pushj p,ttchk		;Look for TTLOC info
	 caia
	  jrst [ push p,a	;  Save the bp for later
		 push p,b	;  Save the TTY number
		 ildb b,a	;  Check out the first character
		 cain b,33	;  Magic escape?
		   jrst [ pop p,b ? sub p,[1,,1] ? jrst type7u]
		 pop p,b	;  Recover the TTY number
		 pop p,a	;  and use the whole thing
		 jrst type7u]	;Use it
	.call [	setz		;have tty no, get kbd no.
		sixbit /tvwher/
		movei 400000(b)
		setzm a ]
	 .value
	cain a,377
	 jrst [	iot [asciz /Not connected/]
		popj p, ]
	cail a,0
	 cail a,maxkbd
	  jrst [iot [asciz / ?? TV-11 garbaged!/]
		popj p,]
	push p,a		;save for later
	pushj p,octhak
	ior a,['kbd00]
	lsh a,6
;	pushj p,type6
	pop p,b			;kbd again
	move a,kbddoc(b)
	hrli a,440700
	pushj p,type7t		;output appropriate stuff
	popj p,

;;; This looks in the SYSBIN;TTLOC DATA file (which was mapped in at the
;;; start) and if there is an entry for that user on that terminal, it
;;; uses the entry instead of the entry from SYSENG;TTYTYP (FILE)
;;; (which was gobbled at initialization time).
;;; The format of the TTLOC DATA file is:
;;; For each TTY, there is a block of 21 words, the first word is
;;; the UNAME of the person on the line, and the rest is an ASCIZ string.
;;; If the UNAME doesn't correspond to who's on the line now,
;;; the entry is cleared and ignored.

;;; B is the TTY number
ttsize==21

ttchk:	push p,b		;save the real B for later
	push p,c
	move c,b
	imuli b,ttsize		;get offset in TTLOC table
	addi b,ttlpag*2000	;make absolute
	move a,unmtab(c)	;get the UNAME that's on this TTY
	skipe 1(b)		;if there's no data in the entry
	  came a,(b)		;  Or there's a new person there
	    jrst ttchk0		;    Clear out the entry
	movei a,1(b)		;yes, return ptr to the ASCIZ string
	hrli a,440700		;make it a Byte Pointer
	pop p,c
	pop p,b			;restore the real TTY #
popj1:	aos (p)			;skip return
	popj p,

ttchk0:	setzm (b)		;clear out the entry
	pop p,c
	pop p,b			;Nope, get back the real B
	popj p,

;here for ordinary vegetable patch tty

nrmtty:	pushj p,ttchk		;check the TTLOC database for interesting info
	  jrst nrmtt0
	push p,a		;remember our TTYLOC
	push p,b		;save the TTY number, we need an AC
	ildb b,a		;fetch the first char
	cain b,33		;Magic escape?
	  jrst [ pop p,b ? sub p,[1,,1] ? jrst type7u] ;just type the rest
	pop p,b			;recover the TTY number
	syscal TTYVAR,[ %climm,,%jsnum(b) ? %climm,,'TYP ? %clout,,a]
	 movei a,0
	trne a,%tydil		;Is this a dialup?
	 jrst [ movei a,[asciz /Dialup: /]  ;Tell about it
		pushj p,type7v
		jrst .+1]
	pop p,a			;recall our TTYLOC
	jrst type7u		;type it out

nrmtt0:	move a,ttydoc(b)	;No TTLOC info, use the default
	jrst type7u

;here when a guy is loggen in on a sty.  If it's a network STY, print host name.
hstout:	pushj p,ttchk		;Check for TTLOC info
	 seto a,		;none
	move b,ttytab(i)	;get host #
	jumpl b,styout	;harumph, non-net sty...go hack it
	push p,a		;Save TTLOC info
	.call [	setz
		sixbit/open/
		[ubpfj+.bii,,usrich]
		[sixbit/usr/]
		auxtb1(i)
		setz auxtb2(i) ] ;open up the server
	 jrst hstou0		;gone
	syscal usrmem,[%climm,,usrich ? %climm,,100 ? %clout,,a]
	 jrst hstou0
	came a,['TERMID]
	 jrst hstou0
	movei a,101
	move b,[-ltlinf,,telinf]	;get cruft
hstou2:	syscal usrmem,[%climm,,usrich ? a ? %clout,,(b)]
	 jrst hstou0
	aos a
	aobjn b,hstou2

;; 3 cases:   (1) We have a console ID from TTLOC.
;; 		  Print the canonicalized host-name which we were given, a
;;		  colon, and the console ID.  If it's a TIP, print the port #.
;;	      (2) We have a console ID from TELSER.  Print it.
;;	      (3) We have no console ID, print Net site and the host name.
;;		  In this case we print the port number for TIP's

	move a,(p)		;get the TTLOC info
	camn a,[-1]		;if there's no TTLOC info
	  skipe termid		;  and if TELSER doesn't know where this TTY is
	    caia
	      jrst hstou3	;    Then we go print the host full name
;This misfeature sucks -- Moon
;	camn a,[-1]		;No TTYLOC info?
;	  jrst hstoyz		;  Don't MPV looking at its first char!
;	ildb b,a		;Check out the first character
;	cain b,33		;Magic escape?
;	  jrst [ pop p,b	;  Yes, discared the saved byte pointer
;		 pushj p,type7u	;  and use the incremented one, discarding escape
;		 jrst hstou4]	;  on with the show.
hstoyz:	pushj p,prthsc		;Print abbreviated host name and optional TIP port number
	movei a,[asciz/: /]
	pushj p,type7v
hstoy0:	pop p,a			;recover our special info
	camn a,[-1]		;unless there's none
	 movei a,termid		;in which case use the TELSER info
	pushj p,type7v		;Type terminal name
	jrst hstou4

;Print host name and TIP number

;This entry used when putting host name before a colon.  Try to abbreviate it.
;Specifically, change MIT-x to x, LISP-MACHINE-x to LMx, SU-AI to SAIL.
;We could change PLASMA to nothing at all (not even colon) but I don't really
;think that's so great (Moon).
prthsc:	push p,b
	move a,[440700,,hstnam]	;Scan name supplied by server
	irpc ch,,[MIT-]
	 ildb b,a
	 caie b,"ch
	  jrst prthc1
	 termin
	pop p,b
	pushj p,type7u		;MIT- host, just show part after MIT-
	jrst prths1

prthc1:	move b,hstnam
	camn b,[ascii/SU-AI/]
	 jrst [	movei a,[asciz/SAIL/]
		pop p,b
		jrst prths0 ]
	push p,c
	push p,d
	move a,[440700,,hstnam]
	move b,[440700,,[asciz/LISP-MACHINE-/]]
prthc2:	ildb c,b
	jumpe c,[typi "L
		 typi "M
		 subi tt,2
		 pop p,d
		 pop p,c
		 pop p,b
		 pushj p,type7u
		 jrst prths1 ]
	ildb d,a
	camn c,d
	 jrst prthc2
	pop p,d
	pop p,c
	pop p,b			;No known abbreviation, print full official name
prthst:	movei a,hstnam
prths0:	pushj p,type7v		;type host name gotten out of server
prths1:	skipn a,tipnum
	 popj p,		;Not a TIP
	subi tt,2		;Port number is at least a # and a digit
	cail a,10		;Subtract additional 1 for each of up to 3 octal digits
	 subi tt,1
	cail a,100
	 subi tt,1
	jumple tt,cpopj		;And exit if no room on line
	typi "#			;port # prefix
	jrst octtyo

;No terminal ID, print net site mumble mumble
hstou3:	pop p,a			;Flush TTLOC info from stack
	movei a,[asciz/Net site /]
	pushj p,type7v
	pushj p,prthst
hstou4:	.close usrich,
	ldb a,[netwrk"nw$byt,,fhost]	;For Public Relations, if was via Chaos net,
	cain a,netwrk"nw%chs	; say so
	 caig tt,8		; but only if there is room on the line
	  jrst hstou5
	movei a,[asciz/ (Chaos)/]
	pushj p,type7v
hstou5:	popj p,

;Here if couldn't get info from server job, treat as non-network STY
hstou0:	.close usrich,
	pop p,a
	jrst styout

styout:	move a,auxtb2(i)	;check for deamon
	camn a,['hactrn]	;only if it is a hactrn
	 jrst styou1
styou2:	iot [asciz /U=/]
	move a,auxtb1(i)	;get uname of controlling proc
	pushj p,type6	;out it go
	iot [asciz / J=/]
	move a,auxtb2(i)	;and then the jname
	pushj p,type6
	popj p,

styou1:	push p,i
	addi i,auxtb1-xuntab	;check if daemon is listed in usrnam
	pushj p,useek
	pop p,i
	jumpe b,styou2		;if has no LSR1 entry, it is no demon.
	move b,tcmxh
	sub b,beglen
styou3:	ildb a,c
	caige a,40
	 popj p,
	idpb a,sptr
	sojg b,styou3
	popj p,

;2 position octal or decimal print of number in a.  Leading 0 replaced by space.
octtyp:	idivi a,10
	caia
dectyp:	 idivi a,10.
	addi a,"0
	cain a,"0
	 movei a,40
	idpb a,sptr
	addi b,"0
	idpb b,sptr
	popj p,

;Type 3 digits of octal, without zero suppression.
octt3:	idivi a,10
	hrlm b,(p)
	pushj p,octt2
	jrst octt1

;Type 2 digits of octal, without zero suppression.
octt2:	idivi a,10
	addi a,"0
	idpb a,sptr
	addi b,"0
	idpb b,sptr
	popj p,

;Type as many digits as needed to print number in a in octal.
octtyo:	idivi a,10
	hrlm b,(p)
	skipe a
	 pushj p,octtyo
octt1:	hlrz b,(p)
	addi b,"0
	idpb b,sptr
	popj p,

;print asciz string <- b.p. in a, printing no more than <tcmxh>-beglen chars.
type7v:	hrli a,440700
	jrst type7u

typ7ta:	hrli a,440700
type7t:	move tt,tcmxh
	sub tt,beglen
type7u:	ildb b,a
	jumpe b,cpopj
	idpb b,sptr
	sojg tt,type7u
	popj p,

	;these routines are intended to snarf up all birthdays from LSR data
	;once per day, and output them during regular updates.
	; messy, hairy, and not recommended for casual reading.
bdyupd:	push p,a
	push p,b
	push p,c
	push p,d
	push p,e
	.call [setz ? 'rqdate ? setzm a]	;get dsk format date
	 jsr reload
	ldb b,[220500,,a]	;get day of month
	movem b,cday
	ldb b,[270400,,a]	;get month (1 = Jan)
	movem b,cmonth
	setom nbdys'		;clear cnt of bdays found.
	move e,lsrtns"datfpg
	lsh e,10.		;e gets address (in LSR1, not core) of 1st (next) entry.
bdyu2:	move b,e
	movei a,ls1c
	pushj p,lsrtns"lsrget	;make sure next entry is in core, get core address in b.
	 jsr die
	hlrz a,(b)		;advance e to point at the following entry.
	jumpe a,bdyu95		;entry length is 0 => eof!
	add e,a
	movei a,lsrtns"i$brth
	pushj p,lsrtns"lsritm	;get the birthday item.
	 jrst bdyu2		;didn't find it?  look at next entry.

	;found a b-day. must now parse. ugh!
	push p,b		;save core addr of entry, so we can get other items.
	move b,a
	move c,[440700,,d]
	setz d,
repeat 3,[ildb a,b
	caig a,40
	 jrst bdyu9
	cail a,"a
	 caile a,"z
	  caia
	   subi a,40		;make uppercase
	idpb a,c
]
	move c,monptr		;get aobjn thru months.
bdyu4:	camn d,montab(c)
	 jrst bdyu5		;aha. rh of C now has month #.
	aobjn c,bdyu4
	jrst bdyu9		;no match, no month found.

bdyu5:	hrrzs c
	came c,cmonth
	 jrst bdyu9		;sigh, not current month.
bdyu6:	ildb a,b
	caile a,40
	 jrst bdyu6
	caie a,40
	 jrst bdyu9

	ildb a,b
	cain a,40
	 jrst .-2
	cail a,"0
	 caile a,"9
	  jrst bdyu9
	movei c,-"0(a)
	ildb a,b
	cail a,"0
	 caile a,"9
	  caia
	jrst [	imuli c,10.
		addi c,-"0(a)
		jrst .+1]
	came c,cday
	 jrst bdyu9

	; egad, this IS his/her/its birthday!  One last check.
	move b,(p)
	movei a,lsrtns"i$grp
	pushj p,lsrtns"lsritm
	 jrst bdyu8		;no group char, go ahead.
	ildb a,a		;get the group char.
	caie a,0		;if no GR, do not show.
	 cain a,"@		;
	  jrst bdyu9		;don't show aliases.
	caie a,"U
	 cain a,"T
	  jrst bdyu9		;also ignore MACSYMA users or random tourist/guest.
	caie a,40
	 cain a,"O		;also ignore non-humans (lusers who don't understand "0")
	  jrst bdyu9
bdyu8:	move a,1(b)		;get the two words which must contain the whole uname.
	move b,2(b)
	aos d,nbdys
	move c,d		;store them in the next bdyunm table entry (2 wds per entry).
	add c,d
	movem a,bdyunm(c)
	movem b,bdyunm+1(c)
bdyu9:	pop p,b
	move d,nbdys
	cail d,bdymax
	 jrst bdyu95		;stop if this was last allowed.
	hlrz a,(b)
	add b,a
	hlrz a,(b)
	jumpn a,bdyu2

;here after scanning entire LSR1 file for people born today.
bdyu95:	setzm bdyptr
	setzm bdyn1
	setzm bdyn2
	skipl d,nbdys
	 jrst [	addi d,1
		cain d,1
		 setom bdyn1
		cain d,2
		 setom bdyn2
		movn d,d
		hrlzs d
		movem d,bdyptr		;store aobjn ptr for table.
		jrst .+1]
	pop p,e
	pop p,d
	pop p,c
	pop p,b
	pop p,a
	popj p,

monptr:	-12.,,1
montab:	0
	irp m,,[JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC]
	asciz /m/
	termin

	; call this when want to print out birthday people.

bdays:	skipn b,bdyptr
	 popj p,
	iot [asciz /Happy Birthday to/]

bdays2:	move a,b		;get addr of start of ascciz string holding next uname.
	addi a,bdyunm(b)
	trne b,-1		;first time through, don't print spacer.
	 jrst [	skipn bdyn2	;print spacing comma. but if only 2 bdys, don't.
		 typi ",
		jrst .+1]
	typi 40
	hlrz c,b
	cain c,-1		;last bday?
	 jrst [	skipn bdyn1	;yes, print "and", unless only one bday.
		 iot [asciz /and /]
		jrst .+1]
	pushj p,type7
	aobjn b,bdays2
	pushj p,ttyfrc		;force out tty buffer.
	popj p,

bdymax==15.		;max # bdays we can know about.
bdyn1:	0		;-1 when only one bday.
bdyn2:	0		;-1 when only 2 bdays.
bdyptr:	0		;has AOBJN ptr into table.
bdyunm:	block bdymax*2	;table of UNAMES of people having birthday today.
			;Each uname is an ASCIZ string, taking up 2 words.

crlf:	asciz /
/

	;rtn to type only up to a ctl char.
type7:	hrli a,440700
	movem a,ty7ptr'
	caia
type8:	 typi (a)
	ildb a,ty7ptr
	cail a,40
	 jrst type8
	popj p,

LS2FLN:	SETZ ? 'FILLEN ? MOVEI DKIC ? SETZM A

LS2CBK:	SETZ ? 'CORBLK
	MOVEI %CBRED	;Read-Only.
	MOVEI %JSELF	;into self
	A		;as specified
	SETZI DKIC	;from file open on channel.

;Map in the inquir data base (INQUIR;LSR1 >)
;Also the TTLOC data base (SYSBIN;TTLOC DATA)

LS2MAP:	PUSH P,A
	PUSH P,B
	MOVEI A,LS1C
	MOVE B,[USRPAG-HIPORG,,USRPAG]	;this block of pages is available for use.
	PUSHJ P,LSRTNS"LSRMAP	;map in LSR1 - index tables and some data pages.
	 JSR DIE
	HRRZ A,B
	MOVEI B,DKIC
	PUSHJ P,NETWRK"HSTMAP	;Map in the HOSTS2 file.
	 JSR DIE
	MOVEM A,LS2LPG		;save # of first page free after LSR data.
	.CALL [	SETZ ? SIXBIT/OPEN/ ? [.BII,,DKIC]
		[SIXBIT/DSK/] ? [SIXBIT/TTLOC/] ? [SIXBIT/DATA/] ? SETZ [SIXBIT /SYSBIN/]]
	 JRST [	;If TTLOC DATA not found, just put a zero page
		.CALL [ SETZ ? 'CORBLK ? MOVEI 0 ? MOVEI %JSELF ? SETZI TTLPAG ]
		 .LOSE %LSSYS
		.CALL [ SETZ ? 'CORBLK ? MOVEI %CBNDW ? MOVEI %JSELF ? MOVEI TTLPAG
			SETZI %JSNEW ]
		 .LOSE %LSSYS
		JRST POPBAJ ]
	.CALL [ SETZ ? 'CORBLK ? MOVEI %CBNDW ? MOVEI %JSELF ? MOVEI TTLPAG ? SETZI DKIC]
	 .LOSE %LSSYS
	.CLOSE DKIC,
POPBAJ:	POP P,B
	POP P,A
	POPJ P,

LS2LPG:	0	; # of page first free after LSR data

.INSRT SYSENG;LSRTNS
.INSRT SYSTEM;CHSDEF

$$HSTMAP==1	;Request various of NETWRK's routines.
$$SYMLOOK==1
$$HOSTNM==1
$$HSTSIX==1
$$CHAOS==1	;Not actually needed, prevents Fascist error message
.INSRT SYSENG;NETWRK

type6:	push p,b
	push p,c
	move b,[440600,,a]
ty1:	ildb c,b
	addi c,40	;convert 6bit to ascii
	idpb c,sptr
	came b,[600,,a]	;bp will be this after typing six characters
	 jrst ty1
	pop p,c
	pop p,b
	popj p,

octhak:	movei b,0
	lshc a,-3	;uses b reg also
	lsh a,3		;effect of lsh's is to separate the octal digits by 3
	lshc a,3.	;and align them on right
cpopj:	popj p,


clrpts:	push p,a
	movsi a,-maxtty-nontty
clrpt2:	setzm ttyunm(a)	;clear name ptr so unmout will re-search.
	aobjn a,clrpt2
	pop p,a
	popj p,


map11:	move a,[-tvpgs,,tvporg]
	setz b,
	.call [setz
		sixbit /corblk/
		1000,,%cbred+%cbndw
		1000,,%jself
		a
		1000,,%jstvb
		setz b]
	 jsr die
	.call [	setz		;energize system wholine
		sixbit /wholin/
		movei tyoc
		setzi 4 ]
	 jsr die
	.call [	setz		;get video input sw # into a
		sixbit /tvwher/
		1000,,tyoc
		movem b
		setzm a ]
	 jsr die
	lsh a,20.		;move into bits 3.4-4.1
	tlo a,37000		;ALU fcn code for MOVEM'ing
	.suset [.stvcreg,,a]	;put in console reg so we've got that buffer
	.suset [.smara,,[0]]	;clear the MAR in case already set.
	setzm tvend		;clear complement bit and reset scroll reg!
	.suset [.smara,,[7,,tvend]] ;set .MAR break so any reference to scroll reg
				;will be caught (something has been garbaging this
				;location randomly)
	tlz a,2000		;get 34000 = ALU fcn code for IORMing into memory
	.suset [.stvcreg,,a]	;put in console reg
	popj p,

gttys:	.call [	setz
		sixbit /open/
		[.bai,,dkic]
		[sixbit /dsk/]
		[sixbit /ttytyp/]
		[sixbit />/]
		setz ['syseng]]
	 jsr die
	move c,[-5000,,ttyfil]
	.iot dkic,c
	skipl c
	 jsr die		;syseng;ttytyp is too big!
	.close dkic,
	move a,[440700,,ttyfil]
gttys0:	ildb b,a
gttys1:	caie b,0
	 cain b,^C	;at eof?
	  jsr die	;yes! no entry in ttytyp for this machine!
	caie b,";	;maybe we've found an entry.
	 jrst gttys0
	ildb b,a
	caie b,";	;an entry has three semicolons, a space, and a machine name.
	 jrst gttys1
	ildb b,a
	caie b,";
	 jrst gttys1
	ildb b,a
	caie b,40
	 jrst gttys1
	move d,mname	;found the semi's and space; now see if machine name is ours.
gttys2:	ildb b,a
	caie b,40
	 cain b,^M
	  jrst gttys3
	andi b,77
	xori b,40
	rot d,6
	xori d,(b)
	trnn d,77
	 jrst gttys2
	ldb b,a
	jrst gttys1

gttys3:	jumpn d,gttys1
	subi b,ttyfil	;the garbage before it.
	sub c,b		;c still had .iot pointer, -> after what was read.
	movsi b,(a)
	hrri b,ttyfil
	blt b,-1(c)
	hrri a,ttyfil	;make a -> same byte, where it has been blt'ed to.
;now find the individual strings in the ttytyp file entry, and put b.p.'s
;to them in the ttydoc table. also replace the crlf's ending them by 0's
;so the ascii typeout routine will work on them.
	move c,[-maxtty,,ttydoc]
gttys4:	ildb b,a
	caie b,0	;eof => no more strings.
	 cain b,^C
	  jrst gttys5
	caie b,";
	 jrst gttys4	;find next documentation string.
	ildb b,a
	cain b,";	;2 semi's in a row => start of next entry
	 jrst gttys5	;meaning end of this one.
	caie b,"T	;comment doesn't start with "Tnm " => ignore it.
	 jrst gttys4
	ildb b,a
	cail b,"0
	 caile b,"9
	  jrst gttys4
	ildb b,a	;don't bother testing the 3rd char for digithood,
	ildb b,a
	caie b,40	;but check 4th for blankness.
	 jrst gttys4
	movem a,(c)	;remember the byte pointer to the string.
	caia
gttys6:	 ildb b,a	;find the end of this string,
	caie b,^M
	 jrst gttys6
	setz b,
	dpb b,a		;and put a ^@ there to stop type7x's printing.
	aobjn c,gttys4
	.value		;too many tty's in ttytyp?!?

gttys5:	popj p,

timint:	push p,a
	hrrz a,-1(p)	;check address running at
	caie a,hang1
	cain a,hang2
	 jrst [ pop p,a
		.call [setz ? sixbit /dismis/ ? p ? setz [lookup]]]
	move a,[600000,,[5*60.]]
	.realt a,
	pop p,a		;running, interrupt will go off again
	.call [setz ? sixbit/dismis/ ? setz p]

ilopr:	0		;here for UUO returned from the system
	skipe forty	;when TV11 crashes, TEN11 sometimes make us execute zero
	 jsr reload
	sos ilopr
	skipn @ilopr	;was instruction supposed to be executed actually zero?
	 jrst [	aos ilopr
		jsr reload ]
11upw:	.suset [.soption,,[<optint+%opopc>,,]]  ;no, wait for 11 to come back up
	skipge @shutdn
	 .logout
	skipl @tt11p
	 .hang
	.suset [.soption,,[<optint+optliv+%opopc>,,]]
	pushj p,map11		;free TV buffer # could have changed!
	jrst lookup		;then restart program

ioc:	push p,a	;i/o channel error.
	hrrz a,-1(p)	;If it came in the middle of doing output to logout times file,
	caie a,iocok1	;wait 10 seconds and try again.
	 cain a,iocok2
	  jrst iocok
	caie a,iocok3
	 cain a,iocok4
	  jrst iocok
	jsr reload

iocok:	movei a,10.*60.
	.sleep a,
	pop p,a
	.call [setz ? 'dismis ? setz p]
	 .lose %lssys

pov:	jsr reload	;pdl overflow

mpv:	jsr reload	;memory protect error


reload: 0
	.value		;later more stuff here

uuoh:	ldb v,[$opcode,,40]
	skipe v
	 caile v,nuuo
	  .value
	jrst @uuotab-1(v)


define uuodef name,handlr
if1 [
ifndef nuuo,nuuo==0
nuuo==nuuo+1
name!nuuo_27.
]
	handlr
termin

uuotab:
	uuodef iot=,u.iot
	uuodef prh=,u.prh
	uuodef prt=,u.prt
	uuodef chr=,u.chr
	uuodef typi=,u.chri

u.chri:	move v,40
	idpb v,sptr
	popj p,

u.chr:	move v,@40	;store a char in output buffer
	idpb v,sptr
	popj p,


u.iot:	hrrz v,40	;block mode output
	hrli v,440700	;set up byte pointer (addr in a as arg.)
	movem v,t7	;store so don't need extra acc
u.i1:	ildb v,t7	;get char
	jumpe v,cpopj	;stop when zero char reached (^@)
	cain v,^C
	 popj p,
	idpb v,sptr	;store in large buffer for later block IOTing
	jrst u.i1

u.prt:	move v,@40
	push p,c
	push p,w
	movei c,2
	idivi v,24.*60.*60.
	move v,w
	jrst at3

u.prh:	move v,@40	;print argument as time
	push p,c
	push p,w
	jumpn v,at1
	movei c,5	;time zero should print as "0:00"
	jrst at3
at1:	setz c,
at2:	camge v,timtb(c)
	aoja c,at2
at3:	idiv v,timtb(c)
	addi v,"0
	skipge @shutdn	;temp. kludge!
	 jrst [	.iot tyoc,v
		jrst .+2]
	idpb v,sptr
	move v,w
	trnn c,1
	aoja c,at3
	cail c,7
	 jrst at4
	skipge @shutdn
	 jrst [	.iot tyoc,[":]
		aoja c,at3]
	push p,w
	movei w,":
	idpb w,sptr
	pop p,w
	aoja c,at3
at4:	pop p,w
	pop p,c
	popj p,

define ptime units
	tdiv*10.
	tdiv
tdiv==tdiv/units
termin	

tdiv==24.*60.*60.

timtb:	ptime 24.
	ptime 60.
	ptime 60.
	ptime 1.

ttyfrc:	push p,a
	push p,b
	move a,[440700,,screen]		;get initial ptr
	move b,sptr			;and current ptr
	pushj p,u7pdif			;find difference
	jumple a,ttyfr9			;don't output if nothing there
	move b,[440700,,screen]		;else do...
	.call [setz ? sixbit /SIOT/
		movei tyoc ? b ? setz a]	;send it out
	 jsr reload
	.call [setz ? sixbit /finish/ ? setzi tyoc]
	 jsr reload		;make sure it goes out.
ttyfr9:	move a,[440700,,screen]
	movem a,sptr		;reset pointer.
	pop p,b
	pop p,a
	popj p,

U7PDIF:	PUSH P,B
	PUSH P,C
	LDB C,[360300,,A]	;get low 3 bits of p (4,5,6,7,0,1)
	MOVEI A,(A)		;get rh
	IMULI A,5
	ADD A,U7BPTB(C)	;add in proper # chars as indicated by p
	LDB C,[360300,,B]
	MOVEI B,(B)
	IMULI B,5
	ADD B,U7BPTB(C)	;both ptrs now in 'canonical' form (# chs from 0)
	SUBM B,A		;get diff B-A into A
	POP P,C
	POP P,B
	POPJ P,			;and return that.

	; # chs in wd	p (index is lower 3 bits)
U7BPTB:	4		;10
	5		;01
	0
	0
	0		;44
	1		;35
	2		;26
	3		;17

QUIT.==.VALUE
SIGN==400000

lotprc:	irps r,,[a b c d e t tt i f g]
	 push p,r
	termin

	skiple lotupk
	 jrst [ pushj p,ltupd0 ? jrst lotprz ]

	addi i,1	;entry+1 is type word
	move a,@dmnbf
	tlnn a,dmnelo
	 jrst lotprz
	addi i,1	;entry+2 is uname
	move a,@dmnbf
	addi i,1	;entry+3 is jname
	move i,@dmnbf
	pushj p,rcdlot
lotprz:	irps r,,[g f i tt t e d c b a]
	 pop p,r
	termin
	popj p,

;following routines taken from pfthmg dragon

RCDLOT:			;"RECORD LOGOUT"
	MOVE B,LOTPT
	MOVEM A,LOTBUF(B) ;STASH UNAME FOR LOGOUT TIMES FILE
	CAMN I,['HACTRN]  ;BUT ONLY FOR HACTRN'S (REAL USERS)
	 AOS I,LOTPT
	.RTIME A,
	SUBI A,LOTUPI
	SKIPG LOTUPK
	 CAML A,LOTUPT
	  JRST LOTUPD
	CAIGE I,LOTBSZ/2	  ;DECIDE IF FILE SHOULD BE UPDATED NOW
	 POPJ P,
LOTUPD:	ADDI A,LOTUPI
	MOVEM A,LOTUPT
LTUPD0:	;ROUTINE TO UPDATE THE LOGOUT TIMES FILE
	;NOTE - TIMES ONLY ACCURATE TO WITHIN 5 MINUTES (LOTUPI)
	;DUE TO THE FACT THAT .RDATIME IS POSTPONED TO HERE

	SETZB C,D		;BEGIN BY CANONICALIZING
LOTUP1:	MOVE B,LOTBUF(C)	;C GET PTR, D PUT PTR
	MOVEI A,0
	LSHC A,6		;BRING IN NEXT CHAR
	TDNE B,[505050505050]	;any good ones left?
	 JRST .-2		;IF SO, LOOP
	TLNE A,770000		;then left adjust
	 JRST .+4
	  LSH A,6
	  JUMPN A,.-3
	   AOJA C,LOTUP2	;IF NO GOOD CHARS, SKIP IT
	TLC A,SIGN		;CHANGE HIGH BIT FOR SORT
	MOVEM A,LOTBUF(D)
	ADDI C,1
	ADDI D,1
LOTUP2:	CAMGE C,LOTPT
	 JRST LOTUP1
	MOVEM D,LOTPT		;-> LAST + 1

	;NOW SORT

LOTSRT:	CAIGE D,2		;MORE THAN ONE LEFT?
	 JRST LOTUP3		;NO, SORTED
	MOVEI C,0		;YES, DO ANOTHER SORT PASS
LOTSR0:	MOVE A,LOTBUF(C)	;THIS ASSUMES ARRAY IS SMALL
	CAMLE A,LOTBUF+1(C)
	 JRST [ EXCH A,LOTBUF+1(C)
		MOVEM A,LOTBUF(C)
		JRST LOTSR1 ]
	CAMN A,LOTBUF+1(C)
	 JRST [	MOVEI A,LOTBUF(C) ;DUPLICATION - BLT DOWN
		HRLI A,1(A)
		SOSG D,LOTPT
		 QUIT.		;DON'T SMASH WORLD TO FLINDERS
		BLT A,LOTBUF-1(D)
		JRST LOTSRT	;RESTART SORT FROM BEGINNING
		 ]		;BECAUSE CAN LOSE OTHERWISE
LOTSR1:	CAIGE C,-2(D)
	 AOJA C,LOTSR0
	SOJA D,LOTSRT

LOTUP3:	MOVE D,LOTPT		;FIX SIGN BITS
	MOVSI A,SIGN
	XORM A,LOTBUF-1(D)
	SOJG D,.-1

	; INITIALIZE DATE & TIME IN LOT ENTRY

	.RDATIM A,		;A := HHMMSS, B := YYMMDD
	ROT B,12.		;B := MMDDYY
	MOVE G,[350700,,LOTNEW+1] ;-> DATE
	PUSH P,A
	PUSHJ P,SIXPUT
	POP P,B
	PUSHJ P,SIXPUT

	;MERGE WITH PREVIOUS LOGOUT TIMES FILE

	MOVEI D,0		;D -> WHICH ENTRY
	PUSHJ P,LOTFILL		;FILL LOTNEW
	.SUSET [.RSNAME,,LOTSNM']
	.SUSET [.SSNAME,,['CHANNA]]
	.OPEN UTYOC,LOTOPO
	 PUSHJ P,RETRY
	.OPEN UTYIC,LOTOPN	;OPEN INPUT FILE
	 JRST LOTEOF		;NO FILE => IMMEDIATE EOF
	JRST LOTUP5

;PUSHJ P,RETRY to wait 10 seconds and retry the previous instruction.
RETRY:	MOVEI D,10.*30.
	.SLEEP D,
	POP P,D
	JRST -2(P)

	;LOGOUT TIMES FILE MERGE
LOTUP5:	MOVE T,[-5,,LOTOLD]	;GET ENTRY FROM FILE
IOCOK4:	.IOT UTYIC,T
	JUMPL T,LOTEOF		;NOT WHOLE ENTRY => EOF
LOTUP4:	MOVE A,LOTOLD		;QUICK COMPARE
	LSH A,-1
	SUB A,LOTCMP
	JUMPG A,LOTUP6		;LOTNEW GOES FIRST
	JUMPL A,LOTUP7		;LOTOLD GOES FIRST
	LDB A,[350700,,LOTOLD+1];HMM, CHECK 6'TH CHAR
	LDB B,[350700,,LOTNEW+1]
	CAMLE B,A
	 JRST LOTUP7		;LOTOLD GOES FIRST
	CAMN B,A
	 SETOM LOTFLG'		;HMM, LOTNEW REPLACES LOTOLD
LOTUP6:	MOVE T,[-5,,LOTNEW]
IOCOK1:	.IOT UTYOC,T
	PUSHJ P,LOTFILL
	AOSE LOTFLG
	 JRST LOTUP4
	JRST LOTUP5		;LOTOLD REPLACED, REFRESH IT

LOTUP7:	MOVE T,[-5,,LOTOLD]
IOCOK2:	.IOT UTYOC,T
	JRST LOTUP5

LOTEOF:	MOVSI A,SIGN-1		;PUT OUT REST OF LOTNEW
	CAME A,LOTCMP
	 JRST LOTEO1
	.CLOSE UTYIC,		;DONE
	.CALL LOTRN		;INSTALL NEW VERSION
	 QUIT.
	.CLOSE UTYOC,
	.SUSET [.SSNAME,,LOTSNM']
	SETZM LOTPT
	POPJ P,

LOTEO1:	MOVE T,[-5,,LOTNEW]
IOCOK3:	.IOT UTYOC,T
	PUSHJ P,LOTFILL
	JRST LOTEOF

SIXPUT:	MOVEI F,6	;SIXBIT IN B, B.P. IN G, SKIP EVERY 2
SIXPU0: MOVEI A,0
	LSHC A,6
	ADDI A,40'
	IDPB A,G
	TRNE F,1	;F ODD IMPLIES SKIP
	 IBP G
	SOJG F,SIXPU0
	POPJ P,

LOTFILL:MOVE F,[440600,,LOTBUF(D)]	;D= ENTRY NO TO
	MOVE G,[440700,,LOTNEW]		; FILL LOTNEW.UNAME FROM
	CAML D,LOTPT		;ANY MORE ENTRIES?
	 JRST LOTFL1		;NO, MARK "EOF"
LOTFL0:	ILDB A,F
	ADDI A,40'
	IDPB A,G
	TLNE F,770000
	 JRST LOTFL0
	MOVE A,LOTNEW		;SET UP COMPARE WORD
	LSH A,-1
	AOSA D			;AND INCREMENT D TO NEXT ENTRY

LOTFL1:	MOVSI A,SIGN-1		;MAKE DUMMY ENTRY
	MOVEM A,LOTCMP'
	POPJ P,

	;LOGOUT TIMES ENTRY BUFFERS

LOTOLD:	BLOCK 5			;READ OLD ONES HERE

LOTNEW:	ASCII\UNAME MM/DD/YY HH:MM:SS
\
IFN .-LOTNEW-5, .ERR LOTNEW LOSES

;Routine to print brief XGP status
;Clobbers all ACs.

xgpsts:	.open usrich,[ubpfj+.bii,,'USR ? sixbit/xgp/ ? sixbit/xgpspl/]
	 popj p,
	.access usrich,[75]	;read abortf, maintp, idlep
	move d,[-3,,a]		;a - abortf - -1 if pdp11 gronked or abort req
	.iot usrich,d		;b - maintp - -1 if in maintenance mode
	.access usrich,[70]	;c - idlep  - 0 running, -1 idle, >0 error code
	hrroi e,d
	.iot usrich,e		;d - cuname - uname of request currently printing
	.close usrich,
	jumpe b,xgpst1
	iot [asciz\   XGP: Maintenance mode\]
	popj p,

xgpst1:	jumpge a,xgpst2
	iot [asciz\   XGP: Aborting/11 down\]
	popj p,

xgpst2:	jumpge c,xgpst3
	iot [asciz\   XGP: Idle\]
	popj p,

xgpst3:	jumpg c,xgpst5
	iot [asciz\   XGP: Printing for \]
xgpst4:	setz c,			;Name of user whose file is being printed
	lshc c,6
	typi 40(c)
	jumpn d,xgpst4
	popj p,

xgpst5:	iot [asciz\   XGP: \]
	movei a,[asciz\strange error condition\]
	trne c,200
	 movei a,[asciz\paper low\]
	trne c,20
	 movei a,[asciz\fuser cold\]
	trne c,10
	 movei a,[asciz\filament cold (paper jam)\]
	trne c,40
	 movei a,[asciz\paper jam\]
	trne c,4
	 movei a,[asciz\web or paper out\]
	iot (a)
	popj p,

define tvkbd num,name/
	loc kbddoc+num
ifse [name],,[asciz /???/]
ifsn [name],,[asciz /name/]
termin

ttydoc:	block maxtty

kbddoc:

.insrt syseng;tvkbd rooms

loc kbddoc+maxkbd

mname:	0	;sixbit name of running machine
	0	;to insure end of the machine name


lpdl==100
pdl:	block lpdl	;push down list

lotbsz==30.
lotbuf:	block lotbsz	;here put unames to go in logout times
lotupt:	0		;time LOGOUT TIMES file last written
lotupi==30.*60.*5.	;update at least every five minutes
lotupk:	0		;force update flag for shutdown (kludgey -1,+1, see code)
lotpt:	0
lotopn:	.bai,,'DSK ? sixbit/logouttimes/
lotopo:	.bao,,'DSK ? sixbit/_drgn_times/
lotrn:	setz ? 'RENMWO ? movei utyoc ? move lotopn+1 ? setz lotopn+2

dwnmlp:	0		;if non-zero is aobjn pointer to down mail
dwnml:	block 40	;read sys:down mail into this block if nec.
dwnmz:	0		;fence for type7
t7:	0		;holds b.p. in type7

cday:	0		;current day, for use by birthday matching.
cmonth:	0		;current month, for same.
chour:	-1		;current hour, when it changes so does picture
cpict:	0		;no. of current picture
pictl:	0		;length of current picture

;The following is copied from location 101 in a TELSER
telinf::
termid:	block 8		;if non-zero, an asciz terminal name
hstnam:	block 8		;if non-zero, the name of the host in asciz
tipnum:	0		;if non-zero, port number on tip
fhost:	0		;foreign host connected to
hstsix:	0		;sixbit name of host
   ;end of stuff looked at by name.
ltlinf==.-telinf


strfre:	440700,,strstg
strstg:	block 20	;useek stores the permuted fullname here.

;these vectors contain 1 elt each per user found.
ttytab:	block maxtty	;for a sty, has host#, or -1 if not connected to Arpanet
svrjob:	block maxtty	;job no. of server associated with sty
unmtab:	block maxtty+nontty	;uname of this user.
xuntab:	block maxtty+nontty	;xuname of this user's tree's top.
jnmtab:	block maxtty+nontty	;jname of job with tty.
jtmtab:	block maxtty+nontty	;usrrce word for tree (ascii idle time for Lisp machine)
auxtb1:	block maxtty	;if under sty belonging to non-stelnt job,
			;this is uname of that job.
auxtb2:	block maxtty	;and this is the jname.
ttyunm:	block maxtty+nontty	;name of loser logged in on this tty
ttynmp:			;address of saved copy of full name of user.
   repeat maxtty+nontty,440700,,ttystr+ttystl*.rpcnt
grpchr:	block maxtty+nontty	;holds group designation char for said loser (0 if none)
relchr:	block maxtty+nontty	;holds relation designation char. 0 if none.
ttystl==10.
ttystr:	block ttystl*<maxtty+nontty>	;storage for fullname strings.  Preallocated per tty.

;Table of Lisp machines.
lmadrs:	block nontty		;Chaos net address, 0 if table entry not used
lmdoc:	repeat nontty, 440700,,lmdcfl+<.rpcnt*10> ;Address of console-location documentation
lmdcfl:	block 10*nontty		;Console-location documentation stored here
lmfree:	block nontty		;-1 if responds but no one logged in
nextlm:	0			;Index of next machine to be connected to
chsidx:	repeat 10,-1		;-1 not in use, else index in lmadrs of guy connected to
chsstm:	block 10		;time transaction started
.vector lmpkt(%cpmxw)

sptr:	0			;byte ptr into output buffer
screen:	block 95.*37./5+1	;space for output to be stored till block IOT
ttyfil:	block 1000
pictur:	block 455.*18.	;area reserved for picture

constants
variables

			;top end of core: start of USRNAM file.
usrpag==<.+1777>/2000
usrfil==usrpag*2000
LS2ORG==USRFIL
end name