;ISIMON:<DOMAIN.VERSION5>GTDOM.MAC.7470, 16-Dec-85 16:56:49, Edit by MOCKAPETRIS
;#747	Version 5 release
;ISIMON:<ISI.MONITOR>GTDOM.MAC.7420,  6-Mar-85 22:14:37, Edit by BILKIS
;#742	Cleaned for general release
;ISIMON:<ISI.MONITOR>GTDOM.MAC.7410, 23-Feb-85 16:36:41, Edit by BILKIS
;#741	Modified for most monitor standards used at ISI, slight
;	reorganization, but retaining duality for now

	.directive sfcond

ifndef djsys,<djsys==1>	;assembling JSYS code if non-zero

define ifdj (arg)<
   ifn djsys,<
	arg>>

define ifndj (arg)<
   ife djsys,<
	arg>>

ifdj <;; definitions if JSYS code generation
	Search	DomSym,Prolog		;#741 Only these first
	ttitle	(GtDom,GtDom,< Paul Mockapetris - Feb 85>)	; domain JSYS
	Search	Imppar,MntPar		;#741 Needed for domain/net code
>; ifdj

Ifndj	<search	domsym,prolog,monsym,macsym,imppar,mntpar>

	Subttl	Local macros and definitions

define djerr (arg)<			;; Unlock and return error code
	jrst [	movei t1,arg		;; set error code
		jrst efinis ]		;; branch to error return
>

ifndj <				;;definitions if not JSYS
callsc:	block 1			;section number when called
morg::	0			;address of master block
mjfn::	0			;jfn used for mapping database
map01::	0			;non-zero if section 0 mapped to section 1
uerc:	block 1			;error code
userac:	block 20		;space for user AC's
dombeg:	0			;count of GTDOM starts

; Local Non-Jsys versions of common macros

	define	NoInt	<>		; A No Op

	define	OkInt	<>		; A No Op

	%djac%==1			;#741 if compiling local ac's

	define	defac(new,old)
<ifndef 'old',<new==%djac%
	       %djac%==%djac%+1>
 ifdef 'old',<new==old>>

	define umove(a,b)<
	move a,userac+b>

	define umovem(a,b)<
	movem a,userac+b>

>; ifndj
	Subttl	Parameters needed for tuning performance or configuration

; database section

	dbfirs=domsec*^d512	;page number of first page
	psize=^d512		;page size
	dblast=dbfirs+psize+psize-1	; 2 sections worth

; miscellaneous
	spd==^d60*^d60*^d24		;seconds per day
	cdelta="z"-"Z"

	Subttl	Global register definitions for domain JSYS use

	defac (t5,q1)			;#741 Must equate to global ac def
	defac (t6,q2)
	defac (t7,q3)
	defac (t8,p1)

	defac (dbase,p2)	;address of master block/origin of
				;shared section 
	defac (flags,p3)	; flags register
	defac (label,p4)	; pointer to byte pointer of label under
				;consideration
	defac (sblock,p5)	; pointer to the search block

; input flags in AC1 which get set by user
	ldo==1b0	; local data only
	mba==1b1	; answer must be authoritative
	rtcp==1b2	; foreign queries should use tcp to avoid truncation
	rewrt==1b3	; rewrite query name
	dnf==1b4	; query name in domain format, not ASCIZ
	das==1b5	; special glue search for addresses
	rbk==1b6	; resolve in background

	gtdtmk==maskb(7,11) ; bits 7-11 reserved for TTL passed to resolver

; mask for input flags
	diflag==ldo+mba+rtcp+rewrt+dnf+das+rbk

; internal flags and status returned in AC1 LH

	rip==1b12	; request terminated with resolver in progress
	nodot==1b13	; suppress dot in name output
	aka==1b14	; alias found
	conly==1b15	; outch to count, not output
	nullok==1b16	; is a null answer considered correct ?
	trun==1b17	; answer was truncated
	Subttl	JSys level code

; 	The GTDOM JSYS dispatches to individual function routines in
; two ways; via the GTDDSP dispatch table, or for NOPs in that
; table, via a jump to the routine for GTHST.
;
;	Domain functions that use the database call routine DSETUP to
;setup pointers to the database, a search block, etc Since these
;routines may acquire locks, they must run NOINT, and use DFINIS et al
;to clean up before exiting.

.GtDom::
ifdj <	mcent				;Establish monitor context
	skipn domsrv			;Don't try if database init failed
	 reterr (gtdx6)			; Domain system error
	hrlzi dbase,domsec		;setup address of database
	skipe dflush(dbase)		; is system flush in progress?
	 reterr (gtdx4)			; if so, data not available
	move t8,p			;save stack pointer
>; ifdj

ifndj <	setzm uerc
	movem 0,userac			;save ac0 to ac17
	move 0,[1,,userac+1]
	blt 0,userac+17
	move t8,p			; for compatibility with JSYS
	xmovei t1,20			; get current section number
	hlrzm t1,callsc			; remember it
	hrlzi dbase,domsec		;setup address of database
	skipn morg			;has database been mapped in ?
	 jrst [skipn callsc		; test section
		jrst [	move t1,[.fhslf,,0]	; if called in zero
		      	move t2,[.fhslf,,1]
			move t3,[sm%rd+sm%wr+sm%ex+sm%ind+1]
			skipn map01
	 		smap%		;make section1 same as section 0
			setom map01	; mark it as done
			xjrstf [0
			       1,,distk]]	;go extended
distk:	       call domini		;map in domain database
		Jfcl			;#741 Ignore funky return
	       jrst .+1]		; and proceed
	xjrstf [exp 0,<1,,.+1>]		;go extended
	hrrz p,p			;extended stack
	umove t1,1			;get AC1 back
>; ifndj

; Common code
	aos	msrdat+dcalls(dbase)	;increment GTDOM% call counter
	hrrz t1,t1			;toss flag bits in AC1 LH
	skipl t1			;Check range of function code
	 cail t1,gtdmax
ifndj	  <jrst badufn >
ifdj	  <reterr (ARGX02)>		;Bad function code

	push p,t1			; function is OK, log it by function
	xmovei t1,msrdat+dbyfn(dbase)	; calculate address of function graph
	add t1,0(p)			; add function
	aos 0(t1)			; increment slot
	pop p,t1			; get function code back

	xct gtddsp(t1)			;dispatch to domain function

ifdj	<jrst .gthst>			;if nothing happens, do GTHST
ifndj	<jrst badufn>			;signal bad function
	Subttl	Dispatch table for GtDom%/GtHst% functions

gtddsp:	nop				;(00)Get name table size (OLD)
	nop				;(01)Index into name space (OLD)
	gnfunc==.-gtddsp
	jrst	gtdnum			;(02)Convert number to string
	gafunc==.-gtddsp
	jrst	gtdstr			;(03)Convert string to number
	nop				;(04)Status by number
	nop				;(05)Status by index
	nop				;(06)Get local number on a network
	nop				;(07)Get status table of a network
	nop				;(10)Get first hop/route to a host
	jrst	gtdgen			;(11)General domain resolution request
	jrst	gtdrwt			;(12)Resolver wait function
	jrst	gtdfus			;(13)Domain file use
gtdmax==.-gtddsp			;Number of functions
	ifn gtdmax-gtdfmx-1,<PRINTX fuction code count error>
	Subttl	DSETUP sets up the database environments for several JSYSes

dsetup:	NoInt				;make sure nothing left locked
	aos msrdat+dscall(dbase)	; increment count of DSETUP calls

; 	Next task is to find and lock a search block in the shared
; domain section(s).  The search blocks are chained in a circular list.
; The search starts at the block pointed to by SBLOOP in the master
; block.  SBLOOP is updated so that these blocks are used in a quasi-fifo
; manner.
	
	move sblock,sbloop(dbase)	;Get address of first search block
	umove flags,1			;setup flags

sblt:	txnn flags,ldo			;use LDO block only if LDO request
	 jrst [	skipe ldores(sblock)	;non-LDO request, does it matter?
		 jrst sbltn		;try next block, this one is LDO
		jrst .+1]

	aose slock(sblock)		;See if we can lock this one
	 jrst [
sbltn:		aos msrdat+dsbbsy(dbase)	; count of busy sblocks
		move sblock,sbnext(sblock)	;get next
		came sblock,sbloop(dbase)	; skip if looped
		 jrst sblt		;try next search block
		aos msrdat+dsbbl(dbase) ;bump all sblocks busy count
		txne	flags,gtdtmk	;see if effort limiting ttl there
		 jrst rbkdie		;kill a bacground request
		skipe dflush(dbase)	;is flush in progress?
		 jrst rbkdie		; if so, kill request
		move	t1,msrdat+lckttl(dbase)	;if tried all wait
		disms
		jrst	sblt]		;before trying again

	movei t1,serch-sbzf-1		;length to blt in order to zero
					; out tail of search block
	setzm sbzf(sblock)
	xmovei t2,sbzf(sblock)
	xmovei t3,sbzf+1(sblock)
	extend t1,[xblt]		;zero out block section

	movem flags,fcode(sblock)	;remember what the user asked for
	and flags,[diflag]

	xmovei label,stable+dstbp-1(sblock)	;setup address of last used pointer
	move t7,[g1bpt 0,8,sname]
	add t7,sblock

	movem t8,psave(sblock)		;save stack pointer for exit

; Initialize tquery to absolute time at start of query
ifndj<	time>
ifdj<	move t1,todclk>
	movem t1,tstart(sblock)		; save MSclock at start of query
	aos msrdat+dfgra+touts(dbase)	;increment query starts count
	Gtad%				; Get current time of day
	sub t1,msrdat+tzero(dbase)	;delta from database creation
	hrrz t2,t1			;t2=day fraction
	hlrz t1,t1			;t1=days
	imuli t1,spd			;convert to seconds
	imuli t2,spd
	idiv t2,[1000000]
	add t1,t2			;add together to make absolute time
	movnm t1,tquery(sblock)		;set absolute reference time
	ret

rbkdie:	aos msrdat+dedoa(dbase)		;bump counter
	okint				; signal recursive death due to
	move p,t8			; lack of resources
ifdj <	reterr (gtdx6)	> ;ifdj
ifndj <	movei t1,gtdx6
	hrrm t1,uerc
	hrrm t1,userac+1
	jrst uexit > ;ifndj
	Subttl	GTDRWT - Resolver wait function
;
;	AC1/12
;	AC2/hold time
;	AC3/wait time
;
;	This function performs resolver blocking
;
gtdrwt:
ifndj <	movei t1,200			; if not JSYS, just delay
	disms
	jrst uexit >
ifdj <	move t1,resjob(dbase)		; make sure its from the resolver
	came t1,jobno			; kill miscreants
	 reterr (gtdx6)
	add t3,todclk			; compute wake up time
	movem t3,domtmr
	skipl 4,reshan(dbase)		; check resolver handle
	 caile 4,niq
	  reterr (gtdx6)
	movei t1,rtst			; get pointer to wait test
	hrl t1,reshan(dbase)		; and resolver handle
	hdisms				; t2 has hold time from call
	mretng

rtst:	skipe intqsp(t1)		; see if packets queued
	 jrst 1(4)			; packets queued means runnable
	move 1,domtmr			; get wake up time
	camg 1,todclk			; compare with now
	 jrst 1(4)			; wake up due to alarm clock
	skipn dombeg			; have any new GTDOM%s happened?
	 jrst 0(4)			; no, back to sleep
	setzm dombeg			; wake up for new requests
	jrst 1(4)	>
	Subttl	GTDFUS - Obtain domain file usage

;
;	BEFORE:				AFTER:
;
;	AC1/13
;	AC2/byte pointer 		AC2/updated byte pointer
;
;	This function returns the filenames for the primary and
;	secondary files in use by GTDOM

gtdfus:	umove t1,2			; get user destination byte pointer
	xmovei t2,msrdat+prifn-1(dbase)	; get address of primary file

ifndj <	move t3,[ point 7,0(t2),35 ]	; simulate cpytus
fus1:	ildb t4,t3
	jumpe t4,fuse
	idpb t4,t1
	jrst fus1

fuse:	umovem t1,2
	idpb t4,t1
	jrst	uexit>

ifdj <	call cpytus			; copy primary file name and update BP
	mretng	>

	Subttl	GTDNUM - Convert number to string

;	BEFORE:				AFTER:
;
;	AC1/2
;	AC2/destination byte pointer	AC2/updated byte pointer
;	AC3/host number	
;					AC4/host status
;
;	This function constructs a domain name for lookup from the address
;	in AC3.  An address of the form 1.2.3.4 translates to
;	4.3.2.1.in-addr.arpa.
gtdnum:	call dsetup			;setup database context
	move t1,t7			;get byte pointer in T1
	movei t3,^d10			;output decimal numbers
	umove t4,3			;host number
	movei t6,4			;four octets to do

ialoop:	movem t1,1(label)		;store byte pointer for this piece
	aos label			;update label pointer
	aos stable+dstcnt(sblock)	;update label count
	move t2,t4			;get host number
	andi t2,377			;mask off eight bits
	lsh t4,-10			;shift input number

	movei t5,1			;compute number of digits
	caile t2,^d9
	 movei t5,2
	caile t2,^d99
	 movei t5,3
	idpb t5,t1			;output label length
	nout				;output number
	 nop
	sojn t6,ialoop			;do it four times

; copy on origin from iaorg
	move t2,[point 8,iaorg(dbase)]

ioloop:	movem t1,1(label)		;set up byte pointer
	aos stable+dstcnt(sblock)	;increment label count
	ildb t3,t2			;get length
	idpb t3,t1			;store length byte
	jumpe t3,iodone			;zero length means done
iosto:	ildb t4,t2
	idpb t4,t1			;store byte of label
	sojn t3,iosto			;loop till label copied
	aoja label,ioloop		;increment label value

iodone:	movei t1,dptr			;looking for pointer
	jrst dlooki			;go do lookup
	Subttl	GTDSTR - Convert string to number

;	BEFORE:				AFTER:
;
;	AC1/3
;	AC2/source byte pointer		AC2/updated byte pointer
;					AC3/host number	
;					AC4/host status
gtdstr:	call dsetup		;set up database context
	pushj p,sindn		;get domain name set up
	movei t1,da
	jrst dlooki		;and look it up	
	Subttl	GTDGEN - General domain resolution request

;	BEFORE:				AFTER:
;
;	AC1/11
;	AC2/source byte pointer		AC2/updated byte pointer
;	AC3/type,,class
;	AC4/destination byte pointer	AC4/updated byte pointer
gtdgen:	call dsetup			;set up database context
	call sindn			;setup input name
	umove t3,3
	hlrzm t3,stype(sblock)		;setup type
	hrrzm t3,sclass(sblock)		;setup class
	ior flags,[nullok]
	jrst dlook
	Subttl	SinDN

;	SINDN - gets a domain name into SNAME using the byte
;	pointer specified by the user in AC2.
;
;	The domain name is in domain name format if DNF is set;
;	otherwise ASCIZ is assumed
;
;	register usage:
;	t1/	source designator
;	t2/	input byte
;	t3/	instruction to fetch next byte
;	t4/	count of octets which can be added to dname
;	t5/	count of octets for label
;	t7/	byte pointer into dname
sindn:	umove t1,2			;get source designator from user
					; register
ifdj	<move t3,[xctbu [ildb t2,t1]]>
ifndj	<move t3,[ildb t2,t1]>
	tlnn t1,777777			;if jfn do JSYS
	 move t3,[BIN]
	tlc t1,777777			;check for LH=-1
	tlcn t1,777777
	 hrli t1,(<point 7,0>)		;use standard pointer
	movei t4,maxdc			;maximum characters in domain name

siloop:	movem t7,1(label)		;save BP to start of name
	aos stable+dstcnt(sblock)	;increment label count
	txnn flags,dnf			;skip if domain name format
	 jrst sinai			;go input ASCIZ
; routine to parse off one domain name format label
	call sinoc			;get and store length
	skipn t6,t2			;process a non-zero length label
	 jrst [ camn t3,[bin]		; done update designator and exit
		 bkjfn
		nop
		umovem t1,2
		ret]
	call sincl			;go check label length
	call sinoc			;get label character
	sojn t6,.-1			;loop through label
	aoja label,siloop		;loop over all labels

sinoc:	xct t3				;get a label character
	 erjmp bada1
sout1:	sojl t4,bada1			; error if more than max
					; characters total
	idpb t2,t7
	ret

sincl:	caile t6,maxlc			; check that t6 is allowable
					; label length
	 jrst bada1
	ret

; routine to parse off one asciz label
sinai:	call sout1			;reserve space for length
	sub t6,t6			;zero count

sina:	call sinoc
	jumpe t2,sinen			;name has ended with a null
	caie t2,"."			; end of label dot found
	 aoja t6,sina			;increment count and loop

	call sincl			;validate length
	move t5,1(label)		;retrieve byte pointer
	idpb t6,t5			;store length
	jumpe t6,[	umovem t1,2	; root end marked by "."
			ret ]
	movx t2,-1		;back up byte pointer
	adjbp t2,t7
	move t7,t2
	aoja label,siloop

sinen:	call sincl			; validate length
	move t5,1(label)		; retrieve byte pointer
	idpb t6,t5			; store length
	jumpe t6,sinbbp			; if root, backup designator and exit

	movx t1,-1			; otherwise create root label first
	adjbp t1,t7
	xmovei label,1(label)
	movem t1,1(label)
	aos stable+dstcnt(sblock)

sinbbp:	camn t3,[BIN]			;fixup designator and exit
	 bkjfn
	  nop
	umovem t1,2
	ret
	Subttl	DLOOK routine looks up the query

;	DLOOKI is entry if t1=type and class=Internet
dlooki:	movem t1,stype(sblock)	;save search qtype
	movei t1,din		;set internet class
	movem t1,sclass(sblock)

dlook:	xmovei t2,msrdat+dbyqt+qslots-1(dbase)	; error slot
	skipg t1,stype(sblock)		;increment by type histogram
	 jrst qtbump			; out of bounds
	cail t1,qslots
	 jrst qtbump			; out of bounds
	xmovei t2,msrdat+dbyqt-1(dbase)	; calculate address of right slot
	add t2,t1
qtbump:	aos 0(t2)			; bump appropriate slot

dlook1:	call ucases			;set case of search name
	xmovei t1,szone(dbase)		;get address of search zone lock
	pushj p,zlocks			;get a sharable lock
	setzm azone(sblock)		;set zone not found
	move t6,szone+znode(dbase)	;get address of root node

azloop:	skipn t7,zonept(t6)		;get pointer to zone
	 jrst azdown			;nothing here
	move t5,sclass(sblock)		;get search class
aztry:	camn t5,zclass(t7)		;try next if classes different
	skipn loaded(t7)		;try next if not loaded
	 jrst [	skipe t7,zchain(t7)
		 jrst aztry		;try next class
		jrst azdown]		;try next level
	movem t7,azone(sblock)		;remember this zone
	movem label,alabel(sblock)	;and its label level

azdown:	xmovei t1,stable+dstbp-1(sblock)
	camn label,t1			;all labels matched ?
	 jrst asdone			;yes
	pushj p,fson			;try to find descendant
	 soja label,azloop		;and loop if next label found

; If we get here either azone is zero, and there is no authoritative
; zone to check, or azone=>zone block and alabel points to the last
; label in SNAME which corresponds to the last label of the SOA name

asdone:	skipe t1,azone(sblock)		;did we find a zone to try?
	 aos msrdat+daztry(dbase)	;increment autoritative zone counter
	skipe t1,azone(sblock)		;did we find a zone to try?
	 pushj p,zlocks			;yes, lock it
	xmovei t1,szone+zonelo(dbase)	;unlock the search zone
	pushj p,ulocks
	skipn t1,azone(sblock)		;check again for authoritative zone
	 jrst cache			;no authoritative zone, go try cache

; next step is to descend though the rest of labels tosee if node there
; or delegated
	move t6,zsoa(t1)		;get address of soa node
	move label,alabel(sblock)
	setzb t7,adeln(sblock)		;zero ns delegation node pointer
	setzm adell(sblock)		;zero delegation level

zsloop:	movem t6,lmatch(sblock)		;remember last match
	skipn nodelc(t6)		;skip if authoritative
	 jrst [ move t7,t6		;take delegation
		movem t7,adeln(sblock)
		movem label,adell(sblock)
		aos msrdat+dazdel(dbase)
		jrst cache ]
	xmovei t1,stable+dstbp-1(sblock)
	camn label,t1			;skip if more labels to match
	 jrst antst			;found node in authoritative zone
	pushj p,fson			;try to match another label
	 soja label,zsloop		;iterate

; named node not there
	jumpn t7,cache			;try cache if delegation was found
	xmovei label,starbp(dbase)	;set label for * search
	move t6,lmatch(sblock)		;return to last success
	pushj p,fson			;look for *
	 jrst anstst
	aos msrdat+dazne(dbase)		;increment name error count
	djerr gtdx2

; found named node or * node covering it
anstst:	aosa msrdat+dazstr(dbase)	; found a star node
antst:	aos msrdat+dazfnd(dbase)	; found the name
anhere:	pushj p,ancopy			;try to copy answers
	 jrst dfinis			;successful, clean up and return
	jumpn t7,cnamel			;if failed but cname found,
					; restart search
; name exists but no matching RRs are there
norrs:	txnn flags,nullok		;is null response allowed ?
	 djerr gtdx3			;GTHST emulators return error
	jrst dfinis			;but general routines say its OK

; authoritative search failed, try the cache
cache:	aos msrdat+dcache(dbase)	; increment cache used count
	txne flags,mba			;ignore cache if must be authoritative
	 jrst rsolve			;invoke resolver
	aos msrdat+dcnmba(dbase)	;increment cache not MBA
	xmovei label,stable+dstbp-2(sblock)	;restart label search
	add label,stable+dstcnt(sblock)	; at label before root
	setzm cdeln(sblock)		;set cache delegation to not found
	skipn t1,cachep(dbase)		;see if a cache exists
	 jrst rsolve			;resolve if no cache
	move t6,znode(t1)		;get pointer to root node of cache
	call zlocks			;get a read lock on the cache

; search down the labels, looking for cache delegation which is better
; than already found authoritative delegation (if any)
csloop:	skipn t1,adell(sblock)		;skip if authoritative delegation found
	 jrst cdelgo			;since none, cache delegation wanted
	camg t1,label			;would cache delegation be better?
	 jrst nocdel			;authoritative delegation better
cdelgo:	skipn t7,rrptr(t6)		;get address of first RR for this node
	 jrst nocdel			;no RRs, so no delegation here
cchek:	move t1,rrttl(t7)		;get expiration time of RR
	camle t1,tquery(sblock)		;should expire after query
	 jrst cdellp
	load t1,rrcla,(t7)		;get class of this RR
	call cmatch			;check class
	 jrst [cdellp:	skipe t7,rrnext(t7)	;more RRs to check?
			 jrst cchek	;yes loop
			jrst nocdel]	;no see if all labels matched
	load t1,rrtyp,(t7)		;get RR type
	caie t1,dns			;skip if name server RR
	 jrst cdellp			;check next if this is not a
					; name server RR 
	movem label,cdell(sblock)	;remember this delegation
	movem t6,cdeln(sblock)

; delegation check complete, now see if search is over
nocdel:	xmovei t1,stable+dstbp-1(sblock)
	camn label,t1
	 jrst [	call ancopy		;search name found, copy answers
		 jrst [	aos msrdat+dcans(dbase)
			jrst dfinis ]	;done if got answers
		jumpn t7,cnamel		;if CNAME found by ancopy, go
					; restart search
		jrst rsolve]		;otherwise go resolve
	call fson			;try to match another label
	 soja label,csloop		;iterate if found
	Subttl	RSolve

; If we get to RSolve either:
;
; the search name was not found in the cache
; 	OR
; the name was found but no data matched the query AND a CNAME was not found
;
; In any case the plan is to set up the search block so that the resolver
; process will attempt to service the query
;
; The JSYS calls the resolver storing 1 in RCOM.  The resolver can use
; all of the information in the search block to speed query processing.
; In particular, ADLEN and CDELN are useful for identiying the name
; server to ask, the resolver process can assume ownerships of the locks
; acquired by the JSYS, and the resolver can read and change the FLAGS
; register via RFLAGS.
;
; The resolver returns control to the JSYS by setting RCOM to zero.
;
; If the resolver encountered an error, it returns it via DERC
;
; If the resolver puts the new RRs in the cache, it points to the node
; where it put them via RSOLVN.

rsolve:	aos msrdat+dresol(dbase)	; attempts to resolve
	txne flags,ldo			;don't resolve if local data only
	 djerr gtdx4			;set data not available error
	skipge resjob(dbase)		; make sure a resolver is waiting
	 djerr gtdx4			; set data not available if not
	aos msrdat+drnldo(dbase)
	call infchk			;check for infinite loops
	movem flags,rflags(sblock)	;store flags for resolver process
	aos @rcomp(sblock)		;mark sblock foir resolver
	aos dombeg			; signal resolver to run
	move t1,msrdat+rwaiti(dbase)	; set initial timeout interval
rwaitl:	txne flags,rbk			; don't wait for background calls
	 jrst [	aos msrdat+drrip(dbase)
		iorx flags,rip		; mark resolver in progress
		djerr gtdx4 ]		; signal data not available
	aos msrdat+drdism(dbase)	; count number of times DISMSed
	disms
	skipge resjob(dbase)		; make sure a resolver is waiting
	 djerr gtdx4			; set data not available if not
	call cflush			; also check for flushing
	move t1,msrdat+rwait(dbase)	;set timeout interval
	skipe @rcomp(sblock)		;skip if resolver finished
	 jrst rwaitl			;loop for resolver

	move flags,rflags(sblock)	;restore flags
	skipe derc(sblock)		;skip if resolver signals error
	 jrst dfinis
	skipn t6,rsolvn(sblock)		; get node pointer
	 jrst norrs			; if nil, no such data RRs
	jrst anhere			;jump to ancopy, etc code which happens
					;to do the right thing
	Subttl	CNameL

;	CNAMEL gets control when the name is found to be an alias;
;	it restarts the search at the cannonical name
;
;	On Entry:
;	T7 points at CNAME RR
cnamel:	aos msrdat+dcncal(dbase)	; increment count of CNAMEL calls
	call infchk			;check for infinite loops
	aos msrdat+dcngo(dbase)		;number of times it worked
	iorx flags,aka			;set alias found bit
	move t1,[g1bpt 0,8,sname]	;make g1bpt to search name
	add t1,sblock
	setzm stable+dstcnt(sblock)	;set component count to zero
	xmovei label,stable+dstbp-1(sblock)
	move t7,rdata(t7)		;use rr pointer to get chunk pointer
	move t7,rrname(t7)		;use chunk pointer to get dname pointer

cnl:	move t3,dlabel+labptr(t7)	;get ulabel pointer
	add t3,[ g1bpt 0,8,ultext]	;make it into byte pointer for label
	ildb t4,t3			;get label length
	movem t1,1(label)		;store byte pointer
	aos stable+dstcnt(sblock)	;increment label count
	idpb t4,t1			;store length
	jumpe t4,cndone			;zero length label means done
cnloop:	ildb t5,t3			;get next octet
	idpb t5,t1			;store label octet
	sojn t4,cnloop			;loop till label done
	move t7,more(t7)		;move on to next label in domain name
	aoja label,cnl			;move on to next byte pointer slot

cndone:	call ulocka			;unlock everything
	jrst dlook			;and start it up again
	Subttl	InfChk	Check for infinite loops

; INFCHK is called before attempting an operation which restarts a
; search.  For example, INFCHK is called before a CNAME restart. Its
; purpose is to prevent infinite loops which can be caused by circular
; CNAMEs or other problems.  It does so by incrementing ERTTL and
; aboring if ERTTL becomes equal to INFTTL
infchk:	aos t1,erttl(sblock)		;increment counter
	came t1,msrdat+infttl(dbase)
	 ret
	aos msrdat+dicdie(dbase)
	djerr gtdx6			;signal system error
	Subttl	ANCOPY tries to copy matching RR data

;	On entry:
;		t6 points at node
;
;	returns +1 if answers copied
;		+2 if no answers found
;
;	On exit:
;		t7 points to CNAME if one found, zero otherwise
ancopy:	setzm cnptr(sblock)		;clear CNAME pointer
	setzm anret(sblock)		;set +2 return
	setom adpref(sblock)		;set address preference to -1
	skipa t7,rrptr(t6)		;get address of next RR

acnext:	 move t7,rrnext(t7)

acloop:	jumpn t7,acgo			;more RRs to check
	skipn anret(sblock)		;test return type
	 aos 0(p)			;set skip return
	move t7,cnptr(sblock)
	ret
acgo:	skipge t1,rrttl(t7)		;get TTL and skip if authoritative
	 jrst [	camg t1,tquery(sblock)	;skip if cache and expired
		 jrst .+1
		jrst acnext ]	;try next RR
	load t1,rrcla,(t7)		;get class of RR
	pushj p,cmatch			;see if classes are compatible
	 jrst acnext
	load t1,rrtyp,(t7)		;get type of RR
	pushj p,tmatch			;see if types are compatible
	 jrst [ cain t1,dcname		;no match, was it a CNAME?
		 movem t7,cnptr(sblock)	;remember cname
		jrst	acnext]		;try next RR if not

	move t5,rdata(t7)		;get address of first chunk
	move t4,litdat(t5)		;get address of litchunk or dname
	hrrz t1,fcode(sblock)		;get function code of JSYS
	cain t1,gafunc			;is it a name to address call?
	 jrst cpyad			; got to routine for this
	cain t1,gnfunc			;is it an address to name call ? 
	 jrst [	call seto2		;set output to ac2
		call dndump		;dump out domain name
		call setnck		;set nickname bit in ac4
		move t2,outins(sblock)	;output null and update user BP
		camn t2,[BOUT]
		 jrst dfinis
		move t1,outbp(sblock)
		bkjfn			;backup and output byte pointer
		 nop
		umovem t1,2
		jrst dfinis]

; if we get here, we will dump the whole RR, formatted as follows:
;    type	2 bytes
;    class	2 bytes
;    ttl	4 bytes
;    length	2 bytes
;    rdata	length bytes

	aos anret(sblock)	;increment count of RRs copied
	call seto4		;set output to designator in ac4
	setzm outcnt(sblock)
	iorx flags,conly	;count only first time
	call rddump
	move t5,rdata(t7)	;get chain address back
	andx flags,<-1-conly>	;turn off counting
	load t2,rrtyp,(t7)	;output RR type
	call outtwo
	load t2,rrcla,(t7)	;output RR class
	call outtwo
	skipge t2,rrttl(t7)	;get TTL, skip if positive
	 jrst [	sub t2,tquery(sblock)
		movm t2,t2	;adjust cache timeout
		jrst .+1]
	call out4
	move t2,outcnt(sblock)	;output rdata length
	call outtwo
	call rddump		;output the rdata fields
	move t1,outbp(sblock)	;update the user's byte pointer
	umovem t1,4
	jrst acnext

cpyad:	ldb t1,[point 16,0(t4),31]
	ldb t2,[point 16,1(t4),15]
	lsh t1,^d16
	add t2,t1		; form IP address in T2
	call setnck		; set possible nickname
	call lpref		; call routine to set precedence in t1
	camg t1,adpref(sblock)	; is this higher than previous
	 jrst acnext		; no go onward
	movem t1,adpref(sblock)	; remember found preference
	aos anret(sblock)	; found something
	umovem t2,3		;store internet address in user ac 3
	jrst acnext

;
; HPREF is a front end to the lpref routine to turn it into
; a PASCAL callable function for use by the resolver
;
; function hpref(address:integer):integer;
;

hpref::	hrlzi dbase,domsec		; setup address of database
	call lpref			; call local precedence routine
	movem t1,1(p)			; store PASCAL function value
	ret				; and return

lpref:	setzm t1		; set highest preference found to zero
	xmovei t3,msrdat+prefm+1(dbase)	; set t3=>mask array (skip zero pref)
	xmovei t4,msrdat+prefv+1(dbase)	; set t4=>value array

prefl:	skipn t5,0(t3)			; fetch mask
	 ret				; zero mask means done
	and t5,t2			; mask with IP address
	came t5,0(t4)			; compare with value
	 jrst prefl1			; if miss go to next entry
	move t1,t3			; calculte array index
	xmovei t5,msrdat+prefm(dbase)	; to yield new precedence
	sub t1,t5
prefl1:	aos ,t3				; bump both array pointers
	aoja t4,prefl			; and loop

setnck:	sub t1,t1	;set u4 nicname bit
	txne flags,aka	;skip if alias
	 movx t1,hs%nck	;set nickname
	umovem t1,4
	ret
	Subttl	RDDUMP dumps a rdata chain

; On entry T5->first chunk
rddump:	move t4,litdat(t5)	;get pointer to data
	skipe ckind(t5)		;skip if literal chunk
	 jrst [ call dndump	;dump a domain name
		jrst rddun ]	;and loop
	add t4,[ g1bpt 0,8,0 ]	;make a byte pointer
	ildb t1,t4		;get high order length
	lsh t1,10
	ildb t2,t4		;get low order length
	add t1,t2
	movem t1,dnlc(sblock)	;remember for countdown
	movem t4,dnbp(sblock)

rddlp:	sosge dnlc(sblock)	;count length down
	 jrst [rddun:	skipe t5,rdmore(t5)	;get address of next chunk
			 jrst rddump
			ret ]
	ildb t2,dnbp(sblock)	;get next character to output
	call outch
	jrst rddlp		;loop for more
	Subttl	DNDUMP outputs a domain name

;	On entry:
;	t4 points at DNAME
;
;	+----------------------+         +-------+-----+-------------+
;  t4-->| labuse | ulabel_ptr  |-------->|       | len | octets...   |
;	|        +-------------+         +-------+-----+-------------+
;	|        | mod bits    |
;	+--------+-------------+
;	|                      |
;

dndump:	iorx flags,nodot	;no dot before first label

dnmore:	move t1,[ point 1,dlabel+casemo(t4)]
	movem t1,dncp(sblock)	;setup case mod bits pointer
	move t3,dlabel+labptr(t4);ulabel pointer
	add t3,[ g1bpt 0,8,ultext]	;byte pointer for length
	movem t3,dnbp(sblock)	;dname byte pointer
	ildb t2,dnbp(sblock)	;get length
	movem t2,dnlc(sblock)	;remember for countdown

	txnn flags,dnf		;skip if domain name output format
	 jrst [	jumpe t2,.+1	;output trailing null
		movei t2,"."	;get a dot ready
		txnn flags,nodot;should the dot go out?
		 call outch	;output it
		andx flags,<-1-nodot>
		jrst .+2]
 	call outch		;output it

dndlp:	sosge dnlc(sblock)	;skip if more
	 jrst [	skipe t4,more(t4)	;skip if more name
		 jrst dnmore
		ret	]		;return if done
	ildb t2,dnbp(sblock)	;get octet of name
	ildb t1,dncp(sblock)	;get case mod bit
	skipe t1		;skip if no case modify
	 addi t2,cdelta		;transform case
	call outch		;output this character
	jrst dndlp
	Subttl	CMATCH tests the class in T1 against the QCLASS in SCLASS

;	returns +1 if not compatible
;	returns +2 if compatible
;
;	TMATCH does the analogous function for types
;
;	EITHER trashes t2
;
cmatch: camn t1,sclass(sblock)
retp2:	 aos 0(p)
	popj p,

tmatch:	move t2,stype(sblock)
	camn t1,t2			; always match if equal
	 jrst retp2
	cain t2,dstar			; match if stype=*
	 jrst retp2
	cain t2,dmailb			; dmailb matches MB, MG, and MR
	 jrst [	cain t1,dmb
		 jrst retp2
		cain t1,dmg
		 jrst retp2
		cain t1,dmr
		 jrst retp2
		ret ]
	cain t2,dmaila			; dmaila matches MF,MD
	 jrst [	cain t1,dmf
		 jrst retp2
		cain t1,dmd
		 jrst retp2
		ret ]
	ret				; a loser
	Subttl	Output routines to store string data in user memory

;	specified by ac2 or ac4
;
;	seto2 and seto4 set up for output
;
;	outch outputs one char in AC2 if CONLY set, trashes ac1 and ac3
;		otherwise it increments outcnt
;
seto4:	umove t1,4
	skipa
seto2:	umove t1,2		;get user destination designator
ifdj	<
	move t2,[xctbu [idpb t2,t1]]
>
ifndj	<
	move t2,[ idpb t2,t1]
>
	tlnn t1,777777		;if JFN do JSYS
	 move t2,[BOUT]
	tlc t1,777777		;check for lh=-1
	tlcn t1,777777
	 hrli t1,(<point 7,0>)	;use standard pointer
	movem t1,outbp(sblock)	;save designator
	movem t2,outins(sblock)	;save instruction
	ret

out4:	rot t2,-20
	call outtwo
	rot t2,20

outtwo:	rot t2,-10
	call outch		;output high order
	rot t2,10		;and fall through for another

outch:	txne flags,conly	;skip if output enabled
	 jrst [	aos outcnt(sblock)
		ret	]
	move t1,outbp(sblock)	;get output byte pointer
	move t3,outins(sblock)	;get instruction to execute
	xct t3
	 erjmp badout		;bad destination
	movem t1,outbp(sblock)
	ret
	Subttl	FSON tries to move down the tree by one label

;	returns +1 if it can
;	returns +2 if it can't
;
;	On entry:
;		label points to byte pointer of search label
;		t6 points at node block
;	On exit:
;		t6 points to node if found, junk otherwise
fson:	skipn downtb(t6)	;see if hash table available
	 skipa t6,downpt(t6)	;get node list from pointer
	pushj p,hashls		;get down pointer from hashing

fsloop:	jumpe t6,retp2		;return failure if no node here
	push p,6		;remember because cmpse reformts byte pointers

	move t2,(label)		;byte pointer of key
	ildb t1,t2		;length of key
	move t5,nodela+labptr(t6)	;adress of ulabel
	add t5,[g1bpt 0,8,ultext]	;one word extended pointer
	ildb t4,t5		;length of candidate

	sub t1,t4		;compute excess length of key
	push p,t1		;save it in case minimum length matches
	skipge t1		;skip if string one is longer
	 ldb t4,t2		;use string one length
	move t1,t4		;make lengths equal

	extend t1,[	cmpse	;do string compare
			0
			0]
	 jrst [	ldb t3,t2	;change t3 to difference in bytes
		ldb t4,t5
		sub t3,t4
		movem t3,0(p)
		jrst .+1]
	pop p,3
	pop p,6
	jumpe t3,retrtn		;zero t3 signals success
	jumpl t3,retp2		;if key is less search failed
	move t6,sidept(t6)	;try next node
	jrst fsloop
	Subttl	HASHLS picks up a hashed down table pointer

;	On entry:
;		LABEL points to the search byte pointer
;		t6 points at the node block
;
;	On exit:
;		t6 points at the head of the node list to search
;
hashls:	move t1,(label)		;byte pointer of label to hash
	ildb t3,t1		;get length byte for counting down
	move t4,t3		;also include it in hash

hlslp:	sojl t3,hlsdon		;finish up if all bytes hashed
	ildb t5,t1		;get a new even byte
	lsh t5,6		;shift it
	add t4,t5		;add it to sum

	sojl t3,hlsdon		;finish up if all bytes hashed
	ildb t5,t1		;get a new odd byte
	add t4,t5		;add it unshifted
	jrst hlslp

hlsdon:	idivi t4,^d1009		;hash it
	add t5,downtb(t6)	;add address of start of hash table
	move t6,(t5)		;get chain head
retrtn:	popj p,
	Subttl	Lock hackers

;	The following routines manipulate locks in the master database.
;	The acquired locks are recorded in the search block in variables
;	lock1 and lock2.  Although the lookup code only acquires locks
;	in share mode, and assumes share mode for release, the locking
;	code does check for locks which may have been acquired in
;	exclusive mode by other parts of the domain system.
;
;	ZLOCKS T1=>zone	change T1 to point to lock, fall though to
;
;	LOCKS T1=>lock	gets lock in shared mode, waiting if required
;			records lock in search block
;
;	ULOCKA		releases all shared locks recorded in search block
;
;	ULOCKS T1=>lock	releases specified lock
;
;	BREAKZ T1=>zone	initiaizes lock in zone to be totally unlocked
;			changes T1 to point to lock
;
;	BREAKL T1=>lock	initializes specified loc
zlocks:	xmovei t1,zonelo(t1)	;change zone address to lock address

locks:	skipe lock1(sblock)	;is this slot open to record lock?
	 jrst [	movem t1,lock2(sblock)	;remember in lock2
		jrst .+2	]
	movem t1,lock1(sblock)	;remember in lock1

lockl:	aose lockwd(t1)		;try to acquire lock
	 jrst [	skipe dflush(dbase)	; see if flush in progress
		 jrst [	camn t1,lock1(sblock)	; forget lock and
			 setzm lock1(sblock)
			camn t1,lock2(sblock)
			 setzm lock2(sblock)
			jrst ffinis ]	;  take Flushing exit
		aos msrdat+dpwait(dbase)
		push p,t1	;remember lock address
		move t1,msrdat+plttl(dbase)	;wait for lock to free up
lwait:		disms
		pop p,t1
		jrst lockl ]
	skipe exclus(t1)	;test for exclusive lock set
	 jrst [	aos msrdat+dewait(dbase)
		setom lockwd(t1);free master lock
		push p,t1	;remember lock address
		move t1,msrdat+lckttl(dbase)	;wait two seconds for free
		jrst lwait ]
	aos share(t1)		;increment share count
	setom lockwd(t1)	;free master lock
	ret			;and return

ulocka:	skipe t1,lock1(sblock)	;free all locked zones
	 pushj p,ulocks
	skipn t1,lock2(sblock)
	 ret

ulocks:	camn t1,lock1(sblock)	;free appropriate lock
	 setzm lock1(sblock)
	camn t1,lock2(sblock)
	 setzm lock2(sblock)
	sos share(t1)		;decrement share count
	ret

breakz:	xmovei t1,zonelo(t1)	;change zone address to lock address

breakl:	setom lockwd(t1)	;set lock to available
	setzm share(t1)		;set share count to zero
	setzm exclus(t1)	;set exclusive count to zero
	ret
	Subttl	UCASE sets the case of a domain name to all upper

;	On entry:
;	t1 points at first octet of domain name
;
;	routine UCASES does the search name
ucases:	move t1,[point 8,sname(sblock)]

ucase:	ildb t2,t1		;get length of label
	jumpe t2,retrtn		;return on zero length

ucasel:	ildb t3,t1		;get character to check
	cail t3,"a"		;skip if too small
	 caile t3,"z"
	  jrst ucasen		;go do next character
	subi t3,cdelta		;adjust to upper case
	dpb t3,t1
ucasen:	sojn t2,ucasel		;go get next character
	jrst ucase		;go get next label
	Subttl	Exit routine
;
;	All terminations of the domain jsys exit through DFINIS
;
;	This routine frees up all locked resources, etc
cflush:	skipn dflush(dbase)		; check for a flush in progress
	 ret				; return if not
ffinis:	movei t1,gtdx4			; flush caused data not available
	jrst efinis

badout:	movei t1,gtdx5
	jrst efinis

bada1:	movei t1,gtdx1		;bad argument 1

efinis:	movem t1,derc(sblock)	;store domain error code

dfinis:	aos msrdat+dfgra+tbacks(dbase)
ifndj<	time>
ifdj<	move t1,todclk>
	sub t1,tstart(sblock)	;compute request service time in MS
	addm t1,msrdat+dfgra+ttotal(dbase)	; add time to total
	idiv t1,msrdat+dfgra+tquanta(dbase)	; compute slot number
	caile t1,tslots			; make sure its within range
	 movei t1,tslots
	xmovei t2,msrdat+dfgra+tdelay(dbase)
	add t1,t2
	aos 0(t1)			; increment appropriate slot
	txnn flags,rip		;is resolver running ?
	 call ulocka		;unlock everything if not
	skipn t1,derc(sblock)	;skip if error return
	 hrr t1,fcode(sblock)	;get function code
	hll t1,flags		;also flag bits
	umovem t1,1		;return in register 1
	skipe t2,derc(sblock)	;get error code,if any, in t2
	 aosa msrdat+dferr(dbase)	; increment DFINIS with erro
	  aos msrdat+dfok(dbase)	; increment DFINIS without error
ifdj <
	move p,psave(sblock)	;restore stack pointer
	txnn flags,rip		;is resolver running?
	 setom slock(sblock)	;unlock the search block if not
	okint
	jumpe t2,skmrtn		;no error, normal return
	emretn			;error return
>; ifdj

ifndj < txnn flags,rip		;is resolver running?
	 setom slock(sblock)	;unlock the search block if not
	movem t2,uerc
uexit:	skipn callsc		;if called from section zero
	 xjrstf [0
		0,,.+1]		;return to normal addrressing
	move p,[userac,,0]	;restore registers
	blt p,p
	skipn uerc
	 aos 0(p)		;update return address if no error
	ret

badufn:	movei t1,ARGX02
	hrrm t1,uerc
	hrrm t1,userac+1
	jrst uexit
>; ifndj
	Subttl	DOMINI is called to initialize the domain database

; The object of this code is to select the best pair of FLIP and FLOP files
; and map one into memory.
;
; The database file names are passed as macros flipfn and flopfn
;
;#741	In the case of Exec level code, Pagem has already initialized
; (created) this section, which will inherit a page map on its first
; reference.
;
;	WARNING: the user version code must be callable from FAKEI

	filver=t5
	jfn1=t6
	jfn2=t7

; First step is to select top pair and open them up
domini::
ifdj	<Trvar	<ofn1,ofn2>>		; Why use acs?
	setz filver,
	Movsi	DBase,DomSec		; Use the domain section

inilp:	movx t1,gj%sht+gj%old		;setup for gtjfn on first file
	hrr t1,filver			;setup gtjfn for first file
	hrroi t2,[ flipfn ]
	Gtjfn%
	 erjmp	[jumpe filver,mfatal
		 Jrst	TLower]		; Try next lower version or die
	move jfn1,t1			;remember jfn
	jumpn filver,gt2		;if not first time, get second file
	hrroi t1,filver			;JFNS to get version of file opened
	move t2,jfn1
	movx t3,<fld(.jsaof,js%gen)>
	Jfns%
	hrroi t1,filver			;do NIN to produce version
	movei t3,^d10
	Nin%
	 nop				;should never fail
	move filver,t2			;remember file version
gt2:	movx t1,gj%sht+gj%old		;setup for gtjfn on first file
	hrr t1,filver			;setup gtjfn for first file
	hrroi t2,[ flopfn  ]
	Gtjfn%
	 erjmp rel1
	move jfn2,t1			;remember second JFN
	movx t2,of%rd+of%wr+of%thw	;try to open jfn2
	Openf%
	 erjmp relb
	move t1,jfn1			;open JFN 1
	Openf%
	 erjmp clo2
; fall through

; Now both are open, so try to map in one page of flip into the first
; page of the domain section, and one page of flop into the second page

ifndj	<hrlz t1,jfn1			; Get jfn for first file
	move t2,[ .fhslf,,domsec*psize]	; map into 1st page of domain section
	movx t3,pm%rwx			; full access
	Pmap%				; Do the mapping
	 erjmp clob			; Punt-o-matic
	hrlz t1,jfn2			; Now second file
	addi t2,1			; Map into second page of 1st section
	Pmap%				; Do it
	 erjmp umapj			; No can do, presume dirty
>; ifndj

ifdj	<Hrlz	t1,jfn1			; jfn1,,0
	Call	JFNOFN			; Convert JFN to ofn,,pn
	 Bug.	(HLT,DMIOF0,Soft,GtDom,<Can't get OFN0 for Flip File>)
	Movem	t1,ofn1			; Save it
	Move	t2,[Pm%RWX!DomIDX]	; Where it goes
	Call	SetMPG			; Map it
	hrlz	t1,jfn2			; jfn2.0
	Call	JFNOFN			; ofn2.0
	 Bug.	(HLT,DMIOF1,Soft,GtDom,<Can't get OFN0 for Flop File>)
	Movem	t1,ofn2			; Save ofn2.0
	Move	t2,[Pm%RWX!DomIDX+psize]	; Map into second page
	Call	SetMPG			; Do it
>; ifdj

; Fall through with first page of both files mapped

; The next problem is to see if the pair can be used, and if so,
; which of the pair should be mapped in
;
; Choices are:
;	jrst umpab - pair not usable, retreat toward a lower generation
;	jrst sflip - use FLIP
;	jrst sflop - use FLOP

ifdj	<xmovei	Dbase,domidx>		; If JSYS, change DBase for the tests
					; Note all exits fix it

; Test version; if either doesn't match, retreat

	movx	t1,dbvern		; Get version # of code
	camn	t1,dbvers(DBase)	; retreat if flip version differs
	 came	t1,dbvers+psize(DBase)	; retreat if flop version differs
	  jrst	umapb			; retreat

; If both are dirty, retreat.  If one dirty, take other. Otherwise onward

	skipe	dirty(DBase)		; skip if flip clean
	 jrst [	skipe dirty+psize(DBase)	; test flop dirtiness
		 jrst umapb		; flop dirty as well
		jrst sflop]		; select flop
	skipe	dirty+psize(DBase)
	 jrst	sflip			; select flip

; Select file with lower zone update.  Otherwise onward

	move	t1,zupdate(DBase)	; get flip zone time
	camge	t1,zupdate+psize(DBase)	; compare against flop zone time
	 jrst	sflop			; FLOP is newer
	came	t1,zupdate+psize(DBase)
	 jrst	sflip

; Select file with lower cache update.  Otherwise onward

	move	t1,cupdate(DBase)	; get flip cache time
	camge	t1,cupdate+psize(DBase)	; compare against flop cache time
	 jrst	sflop			; FLOP is newer
	came	t1,cupdate+psize(DBase)
	 jrst	sflip

; Select FLIP on general principles

	jrst	sflip

sflop:	exch jfn1,jfn2			;select flop by swapping jfns

sflip:	movsi DBase,DomSec		; reset DBase pointer

ifndj	<call umap0			;unmap page 0
	call umap1			;unmap page 1
	hrlz t1,jfn1			;PMAP in whole database
	movx t2,<.fhslf,,dbfirs>
	movx t3,pm%rd+pm%wr+pm%cnt+dblast-dbfirst+1
	pmap				;map in whole database
	 erjmp clob			;on failure, try lower version
>; ifndj

Ifdj	<call	umap0
	call	umap1

	Hrlz	t1,jfn1			; jfn.0
	Call	JfnOfn			; Get OFN on first section
	 Bug.	 (HLT,DMIOF2,Soft,GtDom,<Can't get section 0 OFN>)
	Movem	t1,ofn1			; Save it
	Hrlz	t1,jfn1			; Get this back for a sec
	Hrri	t1,1000			; jfn.2nd section
	Call	JfnOfn			; get it
	 Bug.	 (HLT,DMIOF3,Soft,GtDom,<Can't get section 1 OFN>)
	Movem	t1,ofn2
	Hrli	t1,224000		; This kind o' ptr
	Hlr	t1,ofn1			; Get this back
	Movem	t1,DomSec+MSectb	; Make it a new section ptr
	Hlr	t1,ofn2
	Movem	t1,Dm2Sec+MSectb	; Hahahahaha
>; ifdj

; Fall through...

; ...falling...

; The database is now mapped in
ifndj	<movem	dbase,morg		;mark database as mapped
	movem jfn1,mjfn>

ifdj	<skipn jsysin(dbase)		;mark database as initialized
	  aos jsysin(dbase)
	call dbini			;initialize the database
	setom	domsrv>			; signal all is ready
	RetSkp				;return after database
					; initialized

ifndj<
;
;	This code uses DOMINI to implement the map in for the test
;	version of JEEVES.  See MDEP.PAS for details
;

fakei::	push p,t2
	push p,t3
	call domini
	 jfcl
	pop p,t3
	pop p,t2
	movem jfn1,0(t2)
	movem jfn2,0(t3)
	call dbini
	ret

;
; GDOM performs a general GTDOM request for addresses
;

gdom::	move t1,t2			; setup AC1
	move t2,t3			; setup AC2 input BP
	push p,t4			; save destination BP address
	move t4,0(t4)			; get destination BP into ac4
	move t3,[da,,din]		; set type,,class

ifn dtestv,<
	call .gtdom
	 jrst [	pop p,t3
		movem t4,0(t3)
		setzm 1(p)		; return false
		ret ]
>

ife dtestv,<
	gtdom%
	 erjmp [	pop	p,t3
			movem	t4,0(t3)
			setzm 1(p)	; return false
			ret ]
>
	pop p,t3
	movem t4,0(t3)
	movei t1,1			; return true
	movem t1,1(p)
	ret
	
>;ifndj

dbini:	xmovei t1,msrdat+prifn(dbase)	; primary file name block
	add t1,[ g1bpt 0,7,0 ]		; make byte pointer
	move t2,jfn1
	movei t3,0
	movei t4,0
	jfns%
	xmovei t1,msrdat+secfn(dbase)	; backup file name block
	add t1,[ g1bpt 0,7,0 ]
	move t2,jfn2
	jfns%

	setom resjob(dbase)		; mark no resolver

; now go clear all of the locks
	xmovei t1,szone(dbase)		;unlock search zone
	call breakz

	skipe t1,cachep(dbase)		;unlock cache, if any
	 call [	skipn zonelo+exclus(t1)	;skip if cache was write-locked
		 callret breakz
		setzm cachep(dbase)	;throw cache away
		ret ]

	move t4,szone+znode(dbase)	;get top node of search zone
	xmovei t3,bzlist		;break locks in this zone list
	call walkn

; unlock all search blocks
	move sblock,sbloop(dbase)	;get address of first block
ssetup:	setom slock(sblock)		;break lock
	setzm @rcomp(sblock)		;mark as not to be resolved
	move sblock,sbnext(sblock)	;get next
	came sblock,sbloop(dbase)
	 jrst ssetup
	ret

	Subttl	Highly Conditional subroutines

; Entered with t1 containing a page offset to selected compare buffer
CDirty:
	Lsh	t1,9			; Turn into page offset
ifndj<	add	t1,DBase>		; Reference right dom sec page
ifdj<	skipe	dirty+domidx(t1)>	; Check selected buffer
ifndj<	skipe	dirty(t1)>		; in right place
	 Ret				; File is dirty
	Jrst	RSkp			; Emit proper return

; TLower - go to previous version if can
tlower:
ifndj	<TMsg	<Version >
	 Movx	t1,.Priou
	 Move	t2,FilVer
	 Movei	t3,<5+5>
	 Nout%
	  Nop
	 TMsg	< failed
>>; ifndj
	sojn filver,inilp	;try next lower version
	jrst mfatal

mfatal:
ifdj	<setzm domsrv			; Say no such service?
	Ret>; ifdj

ifndj	<TMsg	<
% Domini/MFatal - Cannot open primary file
>
	 Haltf%
	 Jrst	.-1>; ifndj

Ifndj	<
RSkp:	Aos	(p)
	Popj	P,
>; ifndj

	Subttl	BZLIST called by WALKN for every node in search zone

bzlist:	skipn t2,zonept(t2)		;get address of first zone in list
	 ret				;return if none
bzloop:	xmovei t1,zonelo(t2)		;get address of lock
	call breakl			;break this zone's lock
	skipe t2,zchain(t2)		;get address of next zone in list
	 jrst bzloop			;iterate if more
	ret				;return if list complete
	Subttl	Unmapping and Closing routines

ifndj	<
umap1:	skipa t2,[.fhslf,,dbfirs+1]	;unmap the second page
umap0:	movx t2,<.fhslf,,dbfirs>
; unmap the first page	
	movx t1,-1
	setzm t3
	Pmap%
	 nop
	ret
>; ifndj

ifdj	<
umap0:	Setz	t1,
	Movei	t2,Domidx
	Call	SetMPG			; Unmap first page
	ret

umap1:	Setz	t1,
	Movei	t2,Domidx+psize		; Unmap first page o' other file
	Call	SetMPG			; I love it when a plan comes together
	ret
>; ifdj

umapb:	movsi Dbase,domsec		; reset DBase pointer
	call umap1			;both dirty back up
umapj:	call umap0
clob:	move t1,jfn1			;if PMAP fails close and loop
	Closf%
	 nop
clo2:	move t1,jfn2
	Closf%
	 nop
relb:	move t1,jfn2			;on error, release both jfns and loop
	Rljfn%
	 nop
rel1:	move t1,jfn1			;on error, release jfn1 and try again
	Rljfn%
	 nop
	jrst tlower
	Subttl	WALKN walks a node tree

; On entry:
;
;	t4 points to a node
;	t3 points to routine to execute
;
;	when routine specified by t3 is called,
;		t2 points at node
;		routine may garbage t2
walkn:	move t2,t4			;call at root node
	call (t3)

	skipn t2,downpt(t4)		;skip if only one string of sons
	 jrst [	skipn t2,downtb(t4)
		 ret			;return if no down table
		xmovei t2,labelh-1(t2)	;get address of last table entry

tbloop:		push p,t2		;save table address
		push p,t4		;save starting point
		skipe t4,(t2)		;get actual pointer
		 call callch		;walk string if non-zero
		pop p,t4		;restore starting point
		pop p,t2		;restore table address
		camn t2,downtb(t4)	;was it last one in table?
		 ret			;if so return
		soja t2,tbloop ]

	move t4,t2			;setup node address
callch:	push p,t4			;save node address
	call walkn
	pop p,t4
	skipe t4,sidept(t4)		;get next in list, skip if end
	 jrst callch
	ret
	Subttl	Housecleaning


	dcheck	;verify values for consistency

ifdj	<tnxend>
	end

;;; Local Modes:*
;;; Comment Column:40*
;;; Comment Start:;*
;;; Comment Begin:; *
;;; Auto Fill Column:72*
;;; End:*