Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_SRC_1_19910112 - 6-1-monitor/
There are no other files named in the archive.
;Reduce stack usage in RSOLVE to prevent MONPDL's.
; correct TYPO near IF2 conditional
;SRC:<6.1.MONITOR.STANFORD>GTDOM.MAC.31,  5-Nov-86 13:57:13, Edit by BILLW
; make HSTGOO know about (stanford specific) subnets, somewhat.
;[SU-SIERRA.ARPA]FS1:<DEC.6.1.MERGE>GTDOM.MAC.30, 18-Aug-86 18:21:37, Edit by GROSSMAN
; Use GBLJNO instead of JOBNO in GTDRWT.
;[SU-SCORE.ARPA]PS:<6-1-MONITOR>GTDOM.MAC.29,  8-May-86 17:20:23, Edit by BILLW
; work on not needing two sets of args for ANCOPY (ARGBLK vs ACs)
;[SU-SCORE.ARPA]PS:<6-1-MONITOR>GTDOM.MAC.20,  8-Apr-86 20:33:01, Edit by BILLW
; code to pick the best address for multi-homed hosts. (for .GTHSN function)
;[XX.LCS.MIT.EDU]PS:<DOMAIN.5A>GTDOM.NEW.1,  8-Feb-86 06:23:22, Edit by SRA
;M45 Updated to new resolver code, many jeeves bugfixes, measurement
;    code.  Basic strategy changed to let resolver wait loop run
;    OKINT (resolver now -always- releases search blocks).  Resolving
;    can be disabled while leaving cache and authoritative access
;    alone by setting DOMSRV to +1 (code only sets -1 or 0).
;[MIT-SPEECH]SSY:<5-4-MONITOR>GTDOM.MAC.3, 12-Oct-85 11:55:43, Edit by SRA
;M40 Installation in MIT monitor.  Basicly same code as ISI but massively
;    rewritten to make it readable.  This version still runs NOINT even
;    in the resolver loop, which will have to change.  WOPR only for now.

;Conditional assembly options

ifndef djsys,<djsys==1>			;assembling JSYS code if non-zero
ifndef ftbbn,<ftbbn==0>			;BBN style monitor (.UNV files)

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

	Search	DomSym,Prolog		;General monitor and domain symbols

ifdj <	TTitle	(GtDom,GtDom,< Paul Mockapetris - Feb 85>)>

Ifndj <
	Search	Monsym,Macsym		;Non-monitor, set up standard
	.Requir SYS:MACREL		;environment

ifn ftbbn,< Search Imppar,MntPar>	;BBN style monitor
ife ftbbn,< Search Anaunv>		;DEC style monitor

ifdj <	swapcd>			;Make this code swappable
ifdj <	xswapcd>		;Make this code swappable
	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
morg::	0				;address of master block
uerc:	block	1			;error code
userac:	block	20			;space for user AC's
dombeg:	0				;count of GTDOM% starts (for scheduler)
ddtadr:	0				;ddt entry point if needed
osect:	0				;section we entered from
forkx:	1				;fake FORKX (a la monitor)
dbinit:	0				;zap nonzero to init database

;Local Non-Jsys versions of common macros

	%djac%==0			;if compiling local ac's
define	defac(new,old) <
	ifndef 'old',<new==<%djac%==%djac%+1>>
	ifdef  'old',<new==old>

define	NoInt	<>			;;A No Op
define	OkInt	<>			;;A No Op

define	umove(a,b) <foo==<'b'>&<^-17>
	ife <foo>,<move a,userac+b>
	ifn <foo>,<move a,b>
	purge foo>

define	umovem(a,b) <foo==<'b'>&<^-17>
	ife <foo>,<movem a,userac+b>
	ifn <foo>,<movem a,b>
	purge foo>

define	reterr(code) <			;;(a little wasteful of space, oh well)
	ifnb <code>,<			;;error code specified
		jrst [	movei t1,code	;;load up error code
			hrrm t1,uerc	;;stuff it in error flag word
			hrrm t1,userac+1;;and in user acs
			jrst uexit]	;;go punt
	>				;;end of error code specified
	ifb <code>,<	jrst uexit>	;;not specified, just punt

>; ifndj

;It would be nice if we could put the following in STG, but we need to know
;how big to make it and somehow it doesn't seem like a good idea to make STG
;search DOMSYM just for one symbol (too many potential name conflicts).
ifdj <	RS (domrww,maxsb)>		;resident array for user fork dismiss
	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

;does a resolver exist?
	ereslv==1			;if no resolver, set data not available
					;error if not in zones or cache

	spd==^d<60*60*24>		;seconds per day
	cdelta="z"-"Z"			;case conversion
	Subttl	Global register definitions for domain JSYS use

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

;	defac (savep,p1)	;stack fence (not needed)
	defac (dbase,p2)	;address of master block/database origin
	defac (flags,p3)	;flags register
	defac (label,p4)	;pointer to byte pointer of label
	defac (sblock,p5)	;pointer to search block

;input flags in AC1 which get set by user
	ldo==1b0		;local data only
	mba==1b1		;answer must be authoritative
	rtcp==1b2		;resolve via 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)	;reserved for resolver TTL field

;mask for input flags and fcode

;internal flags and status returned in AC1 LH
	rip==1b12		;request terminated with resolve 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.  In order to permit the jsys to run OKINT
;while waiting for the resolver, the search block is considered
;released once it has been passed to the resolver, and a new one must
;be obtained to get the results (or lack thereof) out of the cache.

ifdj <	mcent				;Establish monitor context
	skipn domsrv			;service turned off?
	 reterr(gtdx6)			;yeah, internal error
	movsi dbase,domsec		;setup address of database
>; ifdj

ifndj <	movem 0,userac			;all save registers
	move 0,[1,,userac+1]
	blt 0,userac+17
	movsi dbase,domsec		;setup address of database
	xmovei t1,0			;see if we are running extended
	movem t1,osect			;save it for exit
	ife. t1				;section zero?
	  skipe morg			;database mapped (been here before)?
	  ifskp.			;nope, then have to create section one
	    movx t1,<.fhslf,,0>		;make section one same as section zero
	    movx t2,<.fhslf,,1>
	    movx t3,<sm%rd!sm%wr!sm%ex!sm%ind!1>
	    movx t1,<.fhslf,,770>	;see if ddt is present
	  camn t1,[-1]			;ddt entry page exists?
	  anskp.			;yup, take ddt with us
	    movx t1,<.fhslf,,770>	;need write access to ddt entry page
	    movx t2,pa%rd!pa%ex!pa%cpy
	    move t1,770000		;get old starting instruction
	    movem t1,ddtadr		;(well known address, sort of)
	  endif.			;section 1 is set up now
	  xjrstf [exp 0,<1,,.+1>]	;jump into it
	  hrrz p,p			;stack is still in section zero
	  move t1,[xjrstf [exp 0,<1,,770002>]]
	  skipe ddtadr			;need to fix ddt address?
	   movem t1,@[0,,770000]	;yup, extend ddt start address
	endif.				;done going extended
	skipn morg			;have we got the database yet?
	 call domini			;no, map it in
	  jfcl				;ignore funky return
	umove t1,1			;get AC1 back
>; ifndj

; Common code
	aos msrdat+dcalls(dbase)	;increment GTDOM% call counter
	tlz t1,-1			;toss flag bits in AC1 LH
	skipl t1			;Check range of function code
	 cail t1,gtdmax
	  reterr (ARGX02)		;Bad function code

	push p,t1			;function is ok, log it by function
	xmovei t1,msrdat+dbyfn(dbase)	;address of function graph
	add t1,(p)			;offset for this function
	aos (t1)			;count this invokation
	pop p,t1			;get back function code
	xct gtddsp(t1)			;dispatch to domain function

ifdj	<jrst .gthst>			;if nothing happens, do GTHST
IFDJ	<XJRST [MSEC1,,.GTHST]>		;If nothing happens, do GTHST
ifndj <	reterr (ARGX02)>		;user context, just punt
	Subttl	Dispatch table for GtDom%/GtHst% functions

gtddsp:	nop				;(00)Get name table size (OLD)
	nop				;(01)Index into name space (OLD)
	jrst	gtdnum			;(02)Convert number to string
	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 function code count error>
	Subttl	DSETUP sets up database environment for database lookups

; 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.  Call with ac1
; containing <flags,,fcode> (ie, contents of user ac1 if first time
; through here).  Unlike previous incarnations of this routine, this
; one gets called more than once per jsys invokation, since it is used
; to get a new search block after returning from a resolver wait.
; Right now if we can't find a search block we DISMS% for a short
; while and try again.  For efficency it might be a good idea to keep
; a word in the master block that keeps track of the number of free
; search blocks, and dismiss to the scheduler until free count becomes
; non-zero.  Needs resolver support, and word should be in portion of
; master block that is locked into memory.  Maybe later, not vital.
; Needs some thought about how to deal with ldo-only sblocks.

dsetup:	NoInt				;make sure nothing left locked
	aos msrdat+dscall(dbase)	;count this DSETUP call
	move sblock,sbloop(dbase)	;Get address of first search block
	do.				;loop looking for lockable block
	  txnn flags,ldo		;if call is restricted to local data
	   skipn ldores(sblock)		;or this block not restricted
	    aose slock(sblock)		;see if we can lock this block
	     aosa msrdat+dsbbsy(dbase)	;nope, count a busy block, onwards
	      exit.			;yup, done looping (yow)
	  move sblock,sbnext(sblock)	;get next
	  came sblock,sbloop(dbase)	;have we gone clear around the chain?
	   loop.			;nope, try next search block
	  aos msrdat+dsbbl(dbase)	;yup, bump all blocks busy count
	  ifxe. flags,gtdtmk		;effort limiting ttl present?
	    okint			;no. nothing is locked, psi ok here
	    move t1,msrdat+lckttl(dbase)	;should dismiss to scheduler
	    disms%			;fudge it, just sleep for a while
	    noint			;psi off again
	    loop.			;try again
	  else.				;was ttl present, time to die...
	    aos msrdat+dedoa(dbase)	;got another deader here
	    okint			;signal recursive death
	    reterr (gtdx6)		;(gasp, thud)
	enddo.				;only get here when found block

	movei t1,serch-sbzf-1		;length to blt in order to zero
	setzm sbzf(sblock)		; out tail of search block
	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
	xmovei label,stable+dstbp-1(sblock)
	move t7,[g1bpt 0,8,sname]	;address of last used pointer
	add t7,sblock
	jxn flags,rip,r			;exit here if called after a resolve

; Initialize tquery to absolute time at start of query
ifndj <	time%>
ifdj  <	move t1,todclk>
	movem t1,tstart(sblock)		;save sys uptime at start of query
	aos msrdat+dfgra+touts(dbase)	;increment query starts count
	gtad%				;get current time of day
	sub t1,tzero(dbase)		;delta from database creation
	muli t1,spd			;<days,,stuff> to <seconds,,stuff>
	ashc t1,-22			;scale down to make absolute time
	movnm t2,tquery(sblock)		;set absolute reference time
	Subttl	GTDRWT - Resolver wait function (and other randomness)
;	This function exists to provide hooks into the monitor for certain
;	resolver functions that can only be done from executive context.
;	Originally this was just for doing scheduler dismisses, but it has
;	been generalized a bit.  LH(AC1) does *not* contain flags like in
;	other GTDOM% functions.  Rather, it contains a subfunction code.
;	At this point there is no documentation of this function other than
;	the following code and comments.  Nobody but the resolver should ever
;	call this function, and it is assumed that people hacking on the
;	resolver will read this code.  Subfunction codes and arguments are
;	subject to arbitrary change without notice.
;	Subfunction zero: resolver scheduler dismiss.
;	AC1/ 0,,12
;	AC2/ hold time
;	AC3/ wait time
;	Subfunction one: unblock jsys context GTDOM% request.
;	AC1/ 1,,12
;	AC2/ search block index (zero offset) of request to unblock.

gtdrwt:					;exec mode resolver functions
ifdj <	skipn domsrv			;make sure database there
	 reterr (gtdx6)			;error if not
	move t1,resjob(dbase)		;make sure its the resolver
	came t1,gbljno			;kill miscreants
	 reterr (gtdx6)
	umove t1,1			;get user function code
	hlrzs t1			;get subfunction code
	jumpl t1,.+3			;(aka SKIP2)
	caig  t1,gtdr.z			;if legal function code
	 xct  gtdr.d(t1)		;dispatch
	reterr(gtdx6)			;punt if that didn't work

;subfunction dispatch table
gtdr.d:	jrst gtdr.0			;subfunction zero (resolver dismiss)
	jrst gtdr.1			;subfunction one (unblock user fork)
	gtdr.z==.-gtdr.d		;length of dispatch table

;subfunction zero, resolver wants to do a scheduler dismiss
ifndj <	movei t1,200			;if not JSYS, just delay
	setzm uerc			;no error encountered
	jrst uexit			;return to user

ifdj <
	add t3,todclk			;compute wake up time
	movem t3,domtmr
	skipl 4,reshan(dbase)		;check resolver handle
	 caile 4,niq
	  reterr (gtdx6)
	movei t1,domsvr			;get pointer to wait test
	hrl t1,reshan(dbase)		;and resolver handle
	hdisms				;t2 has hold time from call

	rescd				;scheduler code must be resident

domsvr::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)

	swapcd				;end of scheduler code, swappable again
	xswapcd				;end of scheduler code, swappable again

;subfunction one, resolver wants to unblock jsys context user fork
ifndj <					;user context code
	setzm uerc			;this is a complete no-op
	jrst uexit			;and it always wins

ifdj  <					;jsys context code
	umove t1,2			;get slot index to unblock
	setzm domrww(t1)		;clear wait word
	mretng				;and return winningly
	Subttl	GTDFUS - Obtain domain file usage

;	AC1/13
;	AC2/byte pointer 		AC2/update 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,prifn-1(dbase)	;get address of primary file

ifndj <	move t3,[point 7,(t2),35]	;simulate cpytus
	  ildb t4,t3
	  jumpe t4,endlp.
	  idpb t4,t1
	umovem t1,2
	idpb t4,t1
	setzm uerc
	jrst uexit

ifdj <	call cpytus			;copy primary file name and update BP
	mretng				;and return to user
	Subttl	GTDNUM - Convert number to string

;	AC1/ 2
;	AC2/ destination designator	AC2/ updated destination designator
;	AC3/ host number	
;					AC4/ host status
;	This function constructs a domain name for lookup from the address
;	in AC3.  An address of the form translates to
;	Currently only HS%NCK is set in status word, this needs to be fixed.

gtdnum:	umove flags,1			;setup flags and fcode
	andx flags,diflag		;clear any unknown flags
	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
	  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
	  sojn t6,top.			;do it four times

; copy on origin from iaorg
	move t2,[point 8,iaorg(dbase)]
	  movem t1,1(label)		;set up byte pointer
	  ildb t3,t2			;get length
	  idpb t3,t1			;store length byte
IFN STANSW,<;;; must count terminating nul label too. 
	  aos stable+dstcnt(sblock)	;increment label count
	  jumpe t3,endlp.		;zero length means done
	    ildb t4,t2
	    idpb t4,t1			;store byte of label
	    sojn t3,top.		;loop till label copied
	  aos stable+dstcnt(sblock)	;increment label count
	  aoja label,top.		;increment label value
	movei t1,dptr			;looking for pointer
	jrst dlooki			;go do lookup
	Subttl	GTDSTR - Convert string to number

;	AC1/ .GTHSN (3)
;	AC2/ source designator		AC2/ updated source designator
;					AC3/ host number
;					AC4/ host status
;	Currently only HS%NCK is set in status word, this needs to be fixed.

gtdstr:	umove flags,1			;setup flags and fcode
	andx flags,diflag		;clear any unknown flags
	call dsetup			;set up database context
	umove t1,2			;get source designator
	call sindn			;get domain name set up
	 djerr(gtdx1)			;lost somehow, punt
	umovem t1,2			;store updated designator
	movei t1,da
	jrst dlooki			;and look it up	
	Subttl	GTDGEN - General domain resolution request

;	AC1/ flags,,.GTDRR (11)		AC1/ updated flags
;	AC2/ address of argument block
;	Argument block format:
;	.GTDLN (0)	Length of block not including this word
;	.GTDQN (1)	Input designator for QNAME
;	.GTDBC (4)	Maximum number of bytes allowed in answer (updated)
;	.GTDBP (5)	Destination designator for output (updated)
;	A zero in .GTDBC means no limit on output.
;	Too few words in the argument block cause an ARGX04 error.
;	More words than are understood will be ignored, since somebody
;	may think of more useful fields someday.

gtdgen:	umove flags,1			;setup flags and fcode
	andx flags,diflag		;clear any unknown flags
	umove t1,2			;get pointer to argument block
	umove t2,.gtdln(t1)		;get length word
	caige t2,.gtdbp			;must be at least through .gtdbp
	 reterr(argx04)			;too few args, punt
	push p,t1			;save argblock address
	call dsetup			;set up database context
	pop p,t2			;get back argblock address
	umove t1,.gtdqn(t2)		;get QNAME
	umove t3,.gtdtc(t2)		;get QTYPE,,QCLASS
	hlrzm t3,stype(sblock)		;setup type
	hrrzm t3,sclass(sblock)		;setup class
	call sindn			;setup input name
	 djerr(gtdx1)			;lost somehow, punt
	txo flags,nullok
	umove t2,2			;argblk address again
	umovem t1,.gtdqn(t2)		;store updated source designator
	jrst dlook			;go do the lookup
	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
; returns +2 on success, +1 on failure (gtdx1)

sindn:					;caller already set T1 for us
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
	  movem t7,1(label)		;save BP to start of name
	  aos stable+dstcnt(sblock)	;increment label count
	  ifxn. flags,dnf		;domain name format?
	    call sinoc			;yup, get and store length
	    skipn t6,t2			;process a non-zero length label
	     exit.			;or done, go update designator
	    call sincl			;go check label length
	    do.				;(what the hell, be consistant...)
	      call sinoc		;get label character
	      sojn t6,top.		;loop through label
	    enddo.			;(...even in real tight loops)
	    aoja label,top.		;loop over all labels
	  else.				;asciz format
	    sojl t4,r			;reserve space for length
	    ibp t7
	    setz t6,			;zero char count
	    do.				;eat one label
	      call sinoc		;get a char
	      jumpe t2,endlp.		;null?
	      caie t2,"."		;or dot?
	       aoja t6,top.		;nope, get another char
	    enddo.			;done getting chars
	    call sincl			;validate length
	    move t5,1(label)		;retrieve byte pointer
	    idpb t6,t5			;store length
	    ife. t6			;root (zero length label)?
	      jumpe t2,endlp.		;yep, exit if marked by null
	      retskp			;two dots, yow, are we supporting 
	    endif.			;random weird formats yet?
	    seto t6,			;back up destination over the dot
	    adjbp t6,t7
	    move t7,t6
	    aoj label,			;count one more label
	    jumpn t2,top.		;wasn't null terminated, next label
	    movem t7,1(label)		;was null, must be root
	    aos stable+dstcnt(sblock)	;count it here too (sigh)
	  endif.			;c'est ca
	camn t3,[bin%]			;back up input designator
	 bkjfn%				;iff it's a file
	  erjmp .+1			;oh well, we tried
	retskp				;done, bye

;read one char, skip return unless error
sinoc:	xct t3				;get a label character
	 erjmp r
	sojl t4,r			;error if more than max
	idpb t2,t7			;characters total

;check label length, skip return if ok
sincl:	caile t6,maxlc			;check that t6 is allowable
	 ret				;label length
	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)

; first step is to look up an authoritative zone, if any
dlook:	call ucases			;set case of search name
	xmovei t1,szone(dbase)		;get address of search zone lock
	call zlocks			;get a sharable lock
	setzm azone(sblock)		;set zone not found
	move t6,szone+znode(dbase)	;get address of root node
	do.				;hairy loop looking for labels
	  skipn t7,zonept(t6)		;get pointer to zone
	  ifskp.			;anything here?
	    move t5,sclass(sblock)	;yup, get search class
	    do.				;loop to find the right class
	      camn t5,zclass(t7)	;try next if classes different
	      skipn loaded(t7)		;try next if not loaded
	      ifskp.			;have we got a winner?
	        movem t7,azone(sblock)		;yeah, remember this zone
	        movem label,alabel(sblock)	;and its label level
	      else.			;wrong class or not loaded
	        skipe t7,zchain(t7)	;is there another one?
	         loop.			;yeah, try next class
	      endif.			;falling....
	    enddo.			;...
	  endif.			;...
	  xmovei t1,stable+dstbp-1(sblock)	;address of last label
	  camn label,t1			;all labels matched ?
	   exit.			;yes, out of here
	  call fson			;try to find descendant
	   soja label,top.		;and loop if next label found
	enddo.				;end of hairy loop

; 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
	skipn t1,azone(sblock)		;did we find a zone to try?
	ifskp.				;yup
	  aos msrdat+daztry(dbase)	;remember that we did
	  call zlocks			;and lock it
	xmovei t1,szone+zonelo(dbase)	;unlock the search zone
	call 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 to see 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
	  movem t6,lmatch(sblock)	;remember last match
	  skipe nodelc(t6)		;authoritative?
	  ifskp.			;nope
	    move t7,t6			;take delegation
	    movem t7,adeln(sblock)
	    movem label,adell(sblock)
	    aos msrdat+dazdel(dbase)
	    jrst cache			;and go look in the cache
	  xmovei t1,stable+dstbp-1(sblock)
	  camn label,t1			;skip if more labels to match
	   jrst antst			;found node in authoritative zone
	  call fson			;try to match another label
	   soja label,top.		;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
	call fson			;look for *
	 jrst anstst			;found * node
	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:	call ancopy			;try to copy answers
	 djerr(gtdx5)			;error writing 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 gtdx1			;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
	txnn flags,rip			;if have been through resolver
	 txnn flags,mba			;or cache data is ok
	  aosa msrdat+dcnmba(dbase)	;then carry on, count this usage
	   jrst rsolve			;else go resolve, can't use cache
	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)
	  skipe t1,adeln(sblock)	;no authoritative delegation?
	  camle t1,label		;or cache delegation better?
	  ifnsk.			;yup, so try for cache delegation
	    skipn t7,rrptr(t6)		;get address of first RR for this node
	  anskp.			;no delegation if no RRs
	    do.				;look at the RRs
	      move t1,rrttl(t7)		;get expiration time of RR
	      camle t1,tquery(sblock)	;should expire after query
		load t1,rrcla,(t7)	;get class of this RR
		call cmatch		;check class
		load t1,rrtyp,(t7)	;get RR type
		caie t1,dns		;better be NS RR
	      anskp.			;ok, this is a delegation
		movem label,cdell(sblock)
		movem t6,cdeln(sblock)	;remember this delegation
	      else.			;bogus for some reason
		skipe t7,rrnext(t7)	;more RRs to check?
		 loop.			;yup, go do it
	      endif.			;otherwise see if all labels matched
	    enddo.			;delegation check complete,
	  endif.			; now see if search is over
	  xmovei t1,stable+dstbp-1(sblock)
	  came label,t1			;matched all labels?
	  ifskp.			;yup
	    call ancopy			;search name found, copy answers
	     djerr(gtdx5)		;error copying answers, punt
	     aosa msrdat+dcans(dbase)	;got answer, flag it and hop...
	      skipa			; ...skip...
	       jrst dfinis		; ...and jump out cause we won
	    jumpn t7,cnamel		;if CNAME found, restart search
	  else.				;not done
	    call fson			;try to match another label
	     soja label,top.		;iterate if found
	  endif.			;otherwise fall through to resolver
	enddo.				;end of moby loop
	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,
; unlocking the search block (and any locks held therein), and clearing
; RWAITW (actually, setting it to something other than our FORKX, that
; something just happens to be zero).  The resolver also calls GTDOM%
; to zero the word in DOMRWW corresponding to the word in RWAITW (since
; the scheduler test is really looking there to avoid page faults).
; If the resolver encountered an error, it either returns an error
; via DERRC(FORKX) or stuffs a LOS RR in the cache.  This comment
; should be fixed when this is settled.
; After this is done the answer, if any, will be in the cache,
; so we get a new search block and restart the search (since
; we are waiting okint for the resolver to finish it could be
; days later by the time we get to this, so we might as well
; check the authoritative data too).
; If the resolver wedges or otherwise loses and you want to turn
; off resolving on the fly, you can do it by setting DOMSRV/ 1
; with MDDT.

rsolve:	aos msrdat+dresol(dbase)	;attempt to resolve
ifdj <	skipg domsrv>			;don't resolve if resolving disabled
	txne flags,ldo!rip		;don't resolve if local data only
	 djerr gtdx4			;set data not available error
	aos msrdat+drnldo(dbase)	;not LDO
	ife ereslv,<djerr gtdx4>	;if no resolver, data isn't available
	call infchk			;check for infinite loops
	 djerr gtdx6			;signal system error if so

;; If we get here we really are going to resolve.
;; Copy data we need out of search block and wake up resolve
	ifxe. flags,rbk			;don't copy sblock if rbk

;Note carefully!  At this point we need to save all of the information needed
;to restart the resolution request.  This includes QCLASS, QTYPE, and the
;domain name.  The goal here is to save all of the info on the stack, and to
;minimize the amount of stack space used.  (The code that this replaces used
;to copy the entire SBLOCK onto the stack, and consumed 341 words of stack
;space!  This resulted in occasional MONPDLs when JOBCOF gets activated).
;Currently, the scheme here is to essentially save QCLASS and QTYPE in the
;first word, and then to save the domain name after that.  Since we don't
;know how big the name is until we've done the copy, we just do the copy
;first prior to allocating the stack space, and then adjust the stack pointer
;appropriately.  We also save the length of the area used, and a pointer to
;.STKRT.  Essentially, we have built a dynamic STKVAR, and can therefore do
;returns at any point in the code.  Even with the STKVAR stuff, the common
;case domain resolution request (at STANFORD.EDU) only needs about 9 words of
;stack space.

	  move t1,sclass(sblock)	;Get the query class
	  hrl t1,stype(sblock)		;Get the query type
	  push p,t1			;Save the type and class
	  push p,tstart(sblock)		;Save the starting time
	  push p,tquery(sblock)		;Save reference time
	  movx t1,^d256			;Get max byte count
	  xmovei t2,sname(sblock)	;Get address of name
	  txo t2,owgp.(8)		;Turn it into a byte pointer
	  xmovei t3,1(p)		;Get address of dest (on stack)
	  txo t3,owgp.(8)		;Make dest into a BP
	  do.				;Loop over all labels
	    ildb label,t2		;Get the length of this label
	    subi t1,1(label)		;Subtract length of label+count byte
	    skipge t1			;Any room left?
	     djerr gtdx6		;Is this the appropriate error???
	    idpb label,t3		;Save it away
	    jumpe label,endlp.		;Quit when we reach 0 length label
	    do.				;Loop over all chars in a label
	      ildb t4,t2		;Get a label char
	      idpb t4,t3		;Stuff it
	      sojg label,top.		;And loop over all characters
	    enddo.			;End of char loop
	    loop.			;On to next label
	  enddo.			;End of per label loop
	  movx t2,^d256+3		;Get max size again (+ round up)
	  sub t2,t1			;Compute # of bytes used
	  ash t2,-2			;Convert to words
	  adjsp p,(t2)			;Fix the stack to cover actual amount
	  addi t2,3			;Account stype, sclass, tstart, tquery
	  push p,t2			;Save the length
	  push p,[msec1,,.stkrt##]	;Save the STKVAR cleanup routine
	movem flags,rflags(sblock)	;store flags for resolver process
	move t1,sbidx(sblock)		;get our slot index
	move t2,forkx			;stuff our fork index into RWAITW
	movem t2,@[gfiwm domsec,rwaitw(t1)]
ifdj <	movem t2,domrww(t1)>		;jsys context really uses this location
	aos msrdat+dresol(dbase)	;count a resolver start
	aos @[gfiwm domsec,rcom(t1)]	;mark block for resolver
	aos dombeg			;signal resolver to run
	txo flags,rip			;resolve now in progress
	ifxn. flags,rbk			;background resolve?
	  aos msrdat+drrip(dbase)	;yep, remember it
	  reterr (gtdx4)		;and signal data not available

;; At this point the resolver is (theoretically) running and we
;; no longer own any locks on anything at all.  Bide time until
;; the resolver terminates.  If we get interrupted or killed it is
;; ok, since the data will end up in the cache anyway.

	okint				;resolver owns locks now, psi ok
	lsh t1,22			;low 9 bits test data is slot idx
	lsh t2,33			;high 9 bits test data is fork idx
	ior t1,t2			;test data in lh
	hrri t1,domusr			;test addr in rh
ifdj  <	mdisms>				;deschedule until resolver done
ifndj <					;if not in monitor have to fake it
	hlrz t3,t1			;save test data
	do.				;loop
	  movei t1,^d5000		;five seconds
	  disms%			;sleep
	  move t1,t3			;snarf test data
	  jsp t4,domusr			;do the test
	   loop.			;not done yet, wait some more
	enddo.				;end of user context fakeout

	move t1,forkx			;our fork
	skipe t1,@[gfiwm domsec,rderc(t1)]
					;resolver claims we got an error
	 reterr				;we hold no locks, punt to user
	call dsetup			;get new search block (and go NOINT)

	pop p,(p)			;Dump the STKVAR return address
	pop p,t1			;Get the STKVAR length
	movns t1			;Make it negative
	adjsp p,(t1)			;Fix the stack
	move t1,1(p)			;Get sclass and stype back
	hrrzm t1,sclass(sblock)		;Get the query class
	hlrzm t1,stype(sblock)		;Get the query type
	move t1,2(p)			;Get the starting time back
	movem t1,tstart(sblock)		;Save it in the SB
	move t1,3(p)			;Get the ref time back
	movem t1,tquery(sblock)		;Restore that too
	xmovei t3,4(p)			;Get address of saved name
	txo t3,owgp.(8)			;Make into a BP
	do.				;Loop over all labels
	  movem t7,1(label)		;Remember the start of this label
	  aos stable+dstcnt(sblock)	;And up label count
	  ildb t1,t3			;Get the length of this label
	  idpb t1,t7			;Save it away
	  jumpe t1,endlp.		;Quit when we reach 0 length label
	  do.				;Loop over all chars in a label
	    ildb t4,t3			;Get a label char
	    idpb t4,t7			;Stuff it
	    sojg t1,top.		;And loop over all characters
	  enddo.			;End of char loop
	  aoja label,top.		;On to next label
	enddo.				;End of per label loop

	jrst dlook			;and go restart search

;; Test routine to hang out until resolver terminates our request.
;; AC1 contains FORKX and SBIDX packed in 9 bit fields (yuk).
;; In user context we look at RWAITW in the master block, in jsys
;; context we look at DOMRWW to avoid page faulting in scheduler.

ifdj  <	rescd>					;sched code must be resident
domusr::lshc 1,-11				;1/ FORKX
	lsh  2,-33				;2/ SBIDX
ifdj  <	jn fkps1,(7),1(4)			;wakeup if PSI is pending
	camn 1,domrww(2)>			;still working for us?
ifndj <	camn 1,@[gfiwm domsec,rwaitw(2)]>	;still working for us?
	 jrst (4)				;ya, let it crunch some more
	jrst 1(4)				;no, unblock and get rolling
ifdj  <	swapcd>					;end of resident code
ifdj  <	xswapcd>					;end of resident code
	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)	;killroy was here
	call infchk			;check for infinite loops
	 djerr gtdx6			;signal system error if so
	aos msrdat+dcngo(dbase)		;we survived that
	txo flags,aka			;set alias found bit
	move t1,[g1bpt 0,8,sname]	;make g1bpt to search name
	add t1,sblock
	setzm stable+dstcnt(sblock)	;zero componant count
	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

	  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,endlp.		;zero length label means done
	    ildb t5,t3			;get next octet
	    idpb t5,t1			;store label octet
	    sojn t4,top.		;loop till label done
	  move t7,more(t7)		;move on to next label in domain name
	  aoja label,top.		;move on to next byte pointer slot
	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)
	 retskp				;is ok, skip return
	aos msrdat+dicdie(dbase)
	ret				;caller should punt with gtdx6
	Subttl	ANCOPY tries to copy matching RR data

;	On entry:
;		t6 points at node
;	returns +1 if (jsys) error writing answer
;		+2 if answers copied
;		+3 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 +3 return
	skipa t7,rrptr(t6)		;get address of next RR
	do.				;(and skip over first instruction)
	  move t7,rrnext(t7)		;look at next RR (unless first time)
	  jumpe t7,endlp.		;exit if no more RRs to check
	  skipl t1,rrttl(t7)		;TTL not authoritative?
	  ifskp.			;yup
	    camle t1,tquery(sblock)	;expired?
	     loop.			;yup, try next RR
	  load t1,rrcla,(t7)		;get class of RR
	  call cmatch			;see if classes are compatible
	   loop.			;they aren't, try next
	  load t1,rrtyp,(t7)		;get type of RR
	  call tmatch			;see if types are compatible
	  ifnsk.			;they aren't
	    cain t1,dcname		;was it a CNAME?
	     movem t7,cnptr(sblock)	;yeah, remember cname
	    loop.			;go look at next RR
	  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
	  caie t1,.gthsn		;is it a name to address call?
	  ifskp.			;yes
	    ldb t1,[point 16,0(t4),31]	;high bytes of address
	    move t2,1(t4)		;low bytes
	    lshc t1,^d16		;combine 'em
	    umovem t1,3			;store internet address in user ac 3
	    txnn flags,aka		;alias?
	     tdza t1,t1			;nope
	     movx t1,hs%nck		;yup, set nickname flag
	    umovem t1,4			;save it for user
	    retskp			;return winningly
IFN STANSW,<;;; pick the best address for a multihomed host.
PRINTX <******* UNDEBUGGED CODE ********>
	    SKIPN ANRET(SBLOCK)		;have we had mutilple A answers?
	     SKIPE RRNEXT(T7)		;or might we have?
	     IFNSK.			;host is multi-homed.
		CALL HSTGOO		;compute "Address Goodness"
		CAMG T2,ANRET(SBLOCK)	; is it better than the last address?
		 JRST TOP.		;no - go on to next address (if any)
		MOVEM T2,ANRET(SBLOCK)	;save goodness
	 	UMOVEM T1,3		;store internet address in user ac 3
		txnn flags,aka		;alias?
		 tdza t1,t1		;nope
		 movx t1,hs%nck		;yup, set nickname flag
		umovem t1,4		;save it for user
		JRST TOP.		;loop through next possible answer
		UMOVEM T1,T3		;only one address.  Return it.
		txnn flags,aka		;alias?
		 tdza t1,t1		;nope
		 movx t1,hs%nck		;yup, set nickname flag
		umovem t1,4		;save it for user
		RETSKP			;return winningly.
	  caie t1,.gthns		;is it an address to name call ? 
	  ifskp.			;yes
	    umove t1,2			;get user destination designator
	    call setout			;set up for output
	    call dndump			;dump out domain name
	    txnn flags,aka		;alias?
	     tdza t1,t1			;nope
	     movx t1,hs%nck		;yup, set nickname flag
	    umovem t1,4			;save it for user
	    move t2,outins(sblock)	;output null and update user BP
	    camn t2,[bout%]		;jsys?
	     retskp			;yeah, don't bother
	    seto t1,			;nope, back up byte pointer
	    adjbp t1,outbp(sblock)	; by one byte
	    umovem t1,2			;write it back to user space
	    retskp			;return win

; 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
	  setzm outcnt(sblock)
	  txo flags,conly		;count only first time
	  call rddump			;fake outputing all the data
	   ret				;can't possibly happen here!
	  umove t1,2			;get pointer to user argument block
	  umove t5,.gtdbc		;get count word
IFN 0*STANSW,<	;;;  Doesn't work!.  Why not?
	  umove t5,.gtdbc(t1)		;get count word
	  ifge. t5			;if user cares about length
	    subi t5,^d10		;subtract fixed length stuff
	    caml t5,outcnt(sblock)	;see if we're going to overflow
	  anskp.			;yup, we are
	    txo flags,trun		;remember that we got truncated
	    exit.			;and get out of here
	  umove t1,.gtdbp(t1)		;get user destination designator
	  call setout			;set up for output
	  move t5,rdata(t7)		;get chain address back
	  txz flags,conly		;turn off counting
	  load t2,rrtyp,(t7)		;output RR type
	  call outtwo
	   ret				;lost, punt
	  load t2,rrcla,(t7)		;output RR class
	  call outtwo
	   ret				;punt
	  skipl t2,rrttl(t7)		;TTL positive?
	  ifskp.			;nope
	    sub t2,tquery(sblock)
	    movms t2			;adjust cache timeout
	  call out4
	   ret				;punt
	  move t2,outcnt(sblock)	;output rdata length
	  call outtwo
	   ret				;punt
	  call rddump			;output the rdata fields
	   ret				;punt
	  umove t1,2			;won, get pointer at user argblock
	  move t2,outbp(sblock)		;update the user's byte pointer
	  umovem t2,.gtdbp(t1)
	  umove t2,.gtdbc(t1)		;get user byte count
	  jumpe t2,top.			;don't bother to update if infinite
	  sub t2,outcnt(sblock)		;subtract bytes we wrote
	  subi t2,^d10			;including fixed length stuff
	  umovem t2,.gtdbc(t1)		;store it back
	  jumpe t2,top.			;loop if any room is left
	  skipe rrnext(t7)		;any RRs we miss for lack of space?
	   txo flags,trun		;yeah, remember that little fact
	enddo.				;end of extremely moby loop
					;done looking when get here
	skipn anret(sblock)		;nope, find anything?
	 aos (p)			;nope, set losing (+3) return
	move t7,cnptr(sblock)		;point at any CNAME we may have found
	retskp				;and return to caller (no jsys error)
	Subttl	RDDUMP dumps a rdata chain

; On entry T5->first chunk
; return +2 unless error writing bytes

rddump:	move t4,litdat(t5)		;get pointer to data
	skipe ckind(t5)			;literal chunk?
	ifskp.				;yup
	  iorx t4,<g1bpt 0,8,0>		;make a byte pointer
	  ildb t1,t4			;get high order length
	  ildb t2,t4			;get low order length
	  lsh t1,10			;in correct position
	  ior t1,t2			;combine 'em
	  movem t1,dnlc(sblock)		;remember for countdown
	  movem t4,dnbp(sblock)
	  do.				;process characters
	    sosge dnlc(sblock)		;count length down
	     exit.			;done
	    ildb t2,dnbp(sblock)	;get next character to output
	    call outch
	     ret			;punt
	    loop.			;next char
	else.				;not a literal chunk
	  call dndump			;dump a domain name
	   ret				;punt
	skipe t5,rdmore(t5)		;get address of next chunk
	 jrst rddump			;there is one, onward
	retskp				;none, go home
	Subttl	DNDUMP outputs a domain name

;	On entry:
;	t4 points at DNAME
;	+----------------------+         +-------+-----+-------------+
;  t4-->| labuse | ulabel_ptr  |-------->|       | len | octets...   |
;	|        +-------------+         +-------+-----+-------------+
;	|        | mod bits    |
;	+--------+-------------+
;	|                      |
;	Returns +2 unless error encountered writing bytes

dndump:	txo flags,nodot			;no dot before first label
	do.				;process labels
	  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
	  ifxe. flags,dnf		;asciz name format?
	  andn. t2			;and not the trailing null?
	    movei t2,"."		;yeah, get a dot ready
	    txzn flags,nodot		;should the dot go out?
	  anskp.			;guess not
	  else.				;have a byte to output
	    call outch			;do it
	     ret			;lost, punt
	  do.				;loop handling label chars
	    sosge dnlc(sblock)		;more?
	     exit.			;no, out of loop
	    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
	     ret			;lost, punt
	    loop.			;next
	  enddo.			;done with this label
	  skipe t4,more(t4)		;more name?
	   loop.			;yup, go do it
	enddo.				;done processing labels
	retskp				;won, return +2

;	CMATCH tests the class in T1 against the QCLASS in SCLASS,
;	TMATCH does the analogous function for types.
;	returns +1 if not compatible
;	returns +2 if compatible
;	no bounds checking is done, so be careful...

cmatch:	push p,t2			;don't smash this register
	move t2,sclass(sblock)		;get class
	came t1,t2			;equal?
	cain t2,dstar			;or wildcard?
	 aos -1(p)			;yup, win
	pop p,t2
	ret				;nope, lose

tmatch:	push p,t2			;don't smash this register
	move t2,stype(sblock)		;get type
	came t1,t2			;always match if match (!)
	cain t2,dstar			;always match if wildcard
	 aos -1(p)
	camn t2,tmtab(t1)		;match appropriate generic qtype
	 aos -1(p)
	pop p,t2
	ret				;lose

;Strictly speaking, this should be done with a hairy macro table,
;but these values are pretty well hardwired into the Internet by now.
;Use -1 as "no match" value just out of paranoia (slightly less common
;as a random value than zero).  This table tracks the definitions in
;MASTER.MAC (one componant of DOMSYM.UNV).

tmtab:	-1				;low bound
	-1				;Address
	-1				;Name server
	dmaila				;Mail destination
	dmaila				;Mail forwarder
	-1				;Canonical name pointer
	-1				;Start Of Authority
	dmailb				;Mailbox
	dmailb				;Mail group
	dmailb				;Mail rename
	-1				;Null RR
	-1				;Well known service
	-1				;Domain name pointer
	-1				;Host information
	-1				;Mailbox information
	dmaila				;New mail agent RR
	-1				;High bound
ifn <.-tmtab-dtype>,<printx TMTAB doesn't match DOMSYM definitions>
	Subttl	Output routines to store string data in user memory

;	setout sets up various things for output, call with
;	user output designator in ac1.
;	outch outputs one char in AC2 if CONLY set, otherwise it
;	increments outcnt.  trashes ac1 and ac3.  skip return
;	unless some kind of error (jsys, presumably)
ifdj  <	move t2,[xctbu [idpb t2,t1]]>	;get appropriate byte handling
ifndj <	move t2,[idpb t2,t1]>		;instruction
	tlcn t1,777777			;if jfn
	 move t2,[bout%]		;do jsys
	tlcn t1,777777			;if hrroi format
	 hrli t1,(<point 7,0>)		;use standard pointer
	movem t1,outbp(sblock)		;save designator
	movem t2,outins(sblock)		;save instruction

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:	ifxe. flags,conly		;output enabled?
	  move t1,outbp(sblock)		;yeah, get output byte pointer
	  move t3,outins(sblock)	;get instruction to execute
	  xct t3
	   erjmp r			;bad destination
	  movem t1,outbp(sblock)
	else.				;output disabled
	  aos outcnt(sblock)		;just count it
	endif.				;done
	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
	  call hashls			;get down pointer from hashing
	do.				;just want one good node...
	  jumpe t6,rskp			;return failure if no node here
	  push p,t6			;CMPSx reformats 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,[exp cmpsn,0,0]	;do string compare
	  ifskp.			;strings differed
	    ldb t3,t2			;change t3 to difference in bytes
	    ldb t4,t5
	    sub t3,t4
	    movem t3,(p)
	  pop p,t3
	  pop p,t6
	  jumpe t3,r			;zero t3 signals success
	  jumpl t3,rskp			;if key is less search failed
	  move t6,sidept(t6)		;try next node
	enddo.				;never get here
	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
	  sojl t3,endlp.		;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,endlp.		;finish up if all bytes hashed
	  ildb t5,t1			;get a new odd byte
	  add t4,t5			;add it unshifted
	  loop.				;waltz around again
	idivi t4,^d1009			;hash it
	add t5,downtb(t6)		;add address of start of hash table
	move t6,(t5)			;get chain head
	ret				;bye
	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:	push p,t2			;we're gonna smash this
	move t2,t1			;to leave ac1 free for disms%
	skipe lock1(sblock)		;is this slot open to record lock?
	ifskp.				;yeah
	  movem t2,lock1(sblock)	;remember in lock1
	else.				;nope
	  movem t2,lock2(sblock)	;remember in lock2
	do.				;loop waiting for lock
	  aosn lockwd(t2)		;try to acquire primative lock
	  ifskp.			;lost
	    aos msrdat+dpwait(dbase)
	    move t1,msrdat+plttl(dbase)	;wait for lock to free up
	    loop.			;go try again
	  skipn exclus(t2)		;test for exclusive lock set
	  ifskp.			;lost
	    aos msrdat+dewait(dbase)
	    setom lockwd(t2)		;free master lock
	    move t1,msrdat+lckttl(dbase)
	    disms%			;wait for lock to free up
	    loop.			;go try again
	  endif.			;ok, we won
	enddo.				;so stop looping
	aos share(t2)			;increment share count
	setom lockwd(t2)		;free master lock
	move t1,t2			;put acs back the way they were
	pop p,t2
	ret				;and return
ulocka:	skipe t1,lock1(sblock)		;free all locked zones
	 call ulocks
	skipn t1,lock2(sblock)
	 ret				;(fall through...)

ulocks:	camn t1,lock1(sblock)		;free appropriate lock
	 setzm lock1(sblock)
	camn t1,lock2(sblock)
	 setzm lock2(sblock)
	sos share(t1)			;decrement share count

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
	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,r			;return on zero length
	do.				;loop looking at chars
	  ildb t3,t1			;get character to check
	  cail t3,"a"			;lowercase letter?
	  caile t3,"z"
	  ifskp.			;yes
	    subi t3,cdelta		;adjust to upper case
	    dpb t3,t1			;and write it back
	  sojn t2,top.			;go get next character
	enddo.				;isn't one, so...
	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

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
	addm t1,msrdat+dfgra+ttotal(dbase)	;add time to total
	idiv t1,msrdat+dfgra+tquant(dbase)	;compute slot (?)
	caile t1,tslots			;paranoia
	 movei t1,tslots
	xmovei t2,msrdat+dfgra+tdelay(dbase)
	add t1,t2
	aos (t1)			;increment appropriate slot
	call ulocka			;unlock everything
	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)	;DFINIS with error
	  aos msrdat+dfok(dbase)	;DFINIS and ok
	setom slock(sblock)		;unlock the search block
ifdj <
	okint				;turn PSI back on
	jumpe t2,skmrtn			;no error, normal return
	emretn				;error return
>; ifdj

ifndj <
	movem t2,uerc
uexit:	skipn osect			;did we start out in section zero?
	 xjrstf [exp 0,<0,,.+1>]	;yes, jump back there
	skipe t1,ddtadr			;fix ddt address if needed
	 movem t1,770000
	movsi p,userac			;restore registers
	blt p,p
	skipn uerc
	 aos (p)			;skip return if no error
>; ifndj
	Subttl	DOMINI is called to initialize the domain database

; the choices are pairs of files called something like:
;	<domain>flip.dd and <domain>flop.dd
; the exact names are passed as macros flipfn and flopfn
; The version to choose is the highest version number such that:
; 	both files exist and can be opened and at least one file is not dirty
; within such a set, select the newest update_date which is not dirty
; In the case of Exec level code, Pagem has already initialized
; (created) this section, which will inherit a page map on its first
; reference.


IFN STANSW&DJSYS,<	;; Define resident storage here to minimize changes to STG
RS DOMIDX,1				;Address of PT of first section
RS DM2IDX,1				;Address of PT of second section
RSI DOMSRV,<0>				;-1 if domain service available

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 ]
	 erjmp	[jumpe filver,mfatal
		 Jrst	TLower]		; Try next lower version or die
	move jfn1,t1			;remember jfn
	ife. filver			;need to get version number?
	  move t2,[1,,.fbgen]		;want one word of FDB
	  movei t3,filver		;where to put it
	  gtfdb%			;get it
	  hlrzs filver			;just want the generation number
	endif.				;ok, now have version number
	movx t1,gj%sht+gj%old		;setup for gtjfn on second file
	hrr t1,filver			;same version number
	hrroi t2,[ flopfn  ]
	 erjmp rel1
	move jfn2,t1			;remember second JFN
	movx t2,of%rd+of%wr+of%thw	;try to open jfn2
	 erjmp relb
	move t1,jfn1			;open JFN 1
	 erjmp clo2

; fall through
; ...falling...

; 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 <IFE STANSW,<
	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!Dm2IDX]	; Map into second page
	Call	SetMPG			; Do it
	HRLZ T1,JFN1			; jfn1,,0
	 BUG.(HLT,DMIOF0,SOFT,GTDOM,<Can't get OFN0 for Flip File>)
	MOVEM T1,OFN1			; Save it
	MOVX T2, <DOMSEC,,0>		; map into first page of first section
	TXO T2,PM%RWX			; What access
	HRLZ T1,JFN2			; jfn2.0
	CALLX (MSEC1,JFNOFN)		; ofn2.0
	 BUG.(HLT,DMIOF1,SOFT,GTDOM,<Can't get OFN0 for Flop File>)
	MOVEM T1,OFN2			; Save ofn2.0
	MOVX T2,<DOMSEC,,PSIZE>	; Map into second page
	TXO T2,PM%RWX			; What access
>; ifdj

; Fall through with files mapped
; ...falling...

; now both are mapped, check internal version number before we ILMNRF!
	call	cdbver			; Check internal version numbers
	 jrst	umapb			; Got a bad one, punt it

; versions are ok, see if they are both dirty
	Setz	t1,			; Say check first file
	Call	CDirty			; See if dirty
	 Jrst	[Movei	t1,1		; Say check 2nd file
		 Call	CDirty
		  jrst	 umapb
		 Jrst	sflop]		;select jfn2
	Movei	t1,1			; Say check second buffer
	Call	CDirty			; Check it
	 jrst fpmap			;second file dirty, select flip

ifdj  <
	move	t2,update+domidx	; Compare update words
	camge	t2,update+psize+domidx	;skip to select flip
	movx	t1,<DOMSEC,,0>		; Compare update words
	move	t2,update(t1)
	camge	t2,update+psize(t1)	;skip to select flip

ifndj <	move	t2,update(DBase)	; Check update word
	camge	t2,update+psize(DBase)>	;skip to select flip

sflop:	 exch jfn1,jfn2			;select flop

fpmap:	Setz	t1,

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 <
	Movei	t2,Domidx
	Call	SetMPG			; Unmap first page
	Setz	t1,
	Movei	t2,Dm2idx		; Unmap first page o' other file
	Call	SetMPG			; I love it when a plan comes together
	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
	MOVX T2,<DOMSEC,,PSIZE>	; Umap first page of other file
	HRLZ T1,JFN1			; jfn.0
	CALLX (MSEC1,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
	CALLX (MSEC1,JFNOFN)		; get it
	 BUG.(HLT,DMIOF3,SOFT,GTDOM,<Can't get section 1 OFN>)
;Sigh.  Now we map all 1024 pages, one at a time.  It only happens once...
	MOVEI T3,1000		;512 pages in first section
	HRLZI T2,DOMSEC		;start at page DOMSEC,,0
	TXO T2,PM%RWX		; What access
	HLLZ T1,OFN1		; and file page OFN1,,0
	CALLX (MSEC1,MSETMP)	;map these pages
	MOVEI T3,1000		;512 pages in second section
	HRLZI T2,DM2SEC		;start at page 0
	TXO T2,PM%RWX		; What access
	HLLZ T1,OFN2		;add in ofn/page 0
	CALLX (MSEC1,MSETMP)	;map these pages

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

; The database is now mapped in, initialize if appropriate

ifndj <	movem dbase,morg		;mark database as mapped
	skipn dbinit			;should we init the database?
	 retskp				;no, done, win
	setzm dbinit			;yes, make sure we don't repeat this

	skipn jsysin(dbase)		;mark database as initialized
	 aos jsysin(dbase)
	move t1,[g1bpt domsec,7,prifn]	;set up filenames in database
	move t2,jfn1			;primary filename
	movx t3,js%spc!js%paf		;full filespec please
	 erjmp r			;shouldn't lose
	move t1,[g1bpt domsec,7,secfn]	;secondary filename
	move t2,jfn2
	 erjmp r

; now go clear all of the locks
	xmovei t1,szone(dbase)		;unlock search zone
	call breakz
	skipn t1,cachep(dbase)		;unlock cache, if any
	  skipe zonelo+exclus(t1)	;cache was write-locked?
	anskp.				;no, we can salvage it
	  call breakz			;so clean it up
	else.				;no cache or cache corrupt
	  setzm cachep(dbase)		;throw cache away
	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
	do.				;loop unlocking search blocks
	  setom slock(sblock)		;break lock
	  move 1,sbidx(sblock)		;get slot index
	  setzm @[gfiwm domsec,rcom(1)]	;mark as not to be resolved
	  setzm @[gfiwm domsec,rwaitw(1)]
ifdj <	  setzm domrww(1)>		;and nobody waiting pending resolve
	  move sblock,sbnext(sblock)	;get next block
	  came sblock,sbloop(dbase)

ifdj  <	setom domsrv>			;signal all is ready
	retskp				;return after database initialized
	Subttl	Highly Conditional subroutines

; Entered with t1 containing a page offset to selected compare buffer
	Lsh	t1,9			; Turn into page offset
ifndj <	add	t1,DBase>		; Reference right dom sec page
ifdj  <
IFE STANSW,< skipn dirty+domidx(t1)>	; Check selected buffer
	ADD T1,[DOMSEC,,0]		; Add base of address
	SKIPN DIRTY(T1)			; Check selected buffer
ifndj <	skipn	dirty(t1)>		; in right place
	 Aos	(p)			; File is clean
	Ret				; Emit proper return

; CDBVer - check database version numbers (flip and flop)
; Makes same assumptions as CDirty (probably bad ones)
CDBVer:	movx	t1,dbvern		; Version number we are looking for
ifdj  <	came	t1,dbvers+domidx>	; Check flip, monitor context
ifndj < came	t1,dbvers(dbase)>	; Check flip, user context
	ifskp.				; If flip is ok...
ifdj  <	came	t1,dbvers+1000+domidx>	; Check flop, monitor context
ifndj < came	t1,dbvers+1000(dbase)>	; Check flop, user context
	anskp.				; And flop is ok
	  aos	(p)			; Both versions ok, skip return
	else.				; saw a bad internal version number
ifdj  <	  Bug.	(CHK,DMIBVR,Soft,GtDom,<Monitor/database version mismatch>)>
ifndj <	  tmsg	<Database internal version number does not match GTDOM code!!!
>>					; Flame loudly but don't crash
	endif.				; (Hope resolver figures this out!)
	ret				; Done in any case, return to user
CDBVer:	movx	t1,dbvern		; Version number we are looking for
	movx T2,<DOMSEC,,0>		; get address where data is mapped.
ifdj  <	came	t1,dbvers(T2)>		; Check flip, monitor context
ifndj < came	t1,dbvers(dbase)>	; Check flip, user context
	ifskp.				; If flip is ok...
ifdj  <	came	t1,dbvers+1000(t2)>	; Check flop, monitor context
ifndj < came	t1,dbvers+1000(dbase)>	; Check flop, user context
	anskp.				; And flop is ok
	  aos	(p)			; Both versions ok, skip return
	else.				; saw a bad internal version number
ifdj  <	  Bug.	(CHK,DMIBVR,Soft,GtDom,<Monitor/database version mismatch>)>
ifndj <	  tmsg	<Database internal version number does not match GTDOM code!!!
>>					; Flame loudly but don't crash
	endif.				; (Hope resolver figures this out!)
	ret				; Done in any case, return to user

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

ifdj <	setzm domsrv			; Say no such service
	SKIPN FILVER			;Failed on first try?
	 RETSKP				; Yes, skip return to avoid bugchk
>; ifdj

ifndj <	TMsg	<
% Domini/MFatal - Cannot open primary file
	 Jrst	.-1
>; 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
	do.				;loop over nodes
	  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
	   loop.			;iterate if more
	enddo.				;weren't any more
	ret				;bye
	Subttl	Unmapping and Closing routines

umap1:	skipa	t2,[.fhslf,,dbfirs+1]	;unmap the second page
umap0:	move	t2,[.fhslf,,dbfirs]	;unmap the first page	
	seto	t1,
	setz	t3,

umapb:	call umap1			;both dirty back up
umapj:	call umap0
clob:	move t1,jfn1			;if PMAP fails close and loop
clo2:	move t1,jfn2
relb:	move t1,jfn2			;on error, release both jfns and loop
rel1:	move t1,jfn1			;on error, release jfn1 and try again
	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)
	skipe t2,downpt(t4)		;only one string of sons?
	ifskp.				;nope
	  skipn t2,downtb(t4)
	   ret				;return if no down table
	  xmovei t2,labelh-1(t2)	;get address of last table entry
	    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			;yes, return
	    soja t2,top.		;no, next
	move t4,t2			;setup node address
					;fall through...
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
IFN STANSW,<;;; routine to check for a host address "Goodness"
; Accepts:  T1/ host number
; returns:  T2/ goodness
;		6 : host is directly connected to a preferred net
;		4 : host is directly connected to an available net
;		3 : a gateway to the host's net is on the preferred net
;		2 : a gateway to the host's net is on an available net.
;		1 : host is at least 2 hops away..
; At present, this code does not know about Subnets, or fast nets/gateways
; vs slow nets/gateways.  Maybe someday.
HSTGOO:	SKIPN SUBNTF		;Stanford Subnetting ?
IF2,<Printx HSTGOO assumes Class A net, 8 bit subnets.>
	 MOVE T2,T1			;get copy of host address
	 XOR T2,PRFADR			;XOR with our preferred address
	 CAIL T2,200000			;were net+subnet the same
	  MOVEI T2,7			;yes - try to prefer this address
	ENDIF.				;otherwise, continueu
	NETNUM T2,T1			;Get network number of destination
	 MOVEI T2,6			;really good address.
;Now check if we have ANY interface direct to the desired net
	XMOVEI T3,NCTVT			; Point to the NCT table
	 LOAD T3,NTLNK,(T3)		; Get net in the chain
	 JUMPE T3,ENDLP.		; no more Interfaces - failure
	 CAME T2,NTNET(T3)		; sam	e network?
	  LOOP.				; No, loop
	 MOVEI T2,4			;YES. return goodness level 4
; now check if we know of any gateways connected directly to the specified net
	SAVEAC T1			;save t1
	CALL FNDGAT			;find a gateway
	IFSKP.				; one has been found...
	 MOVE T1,.GWILS(T1)		;get its (local) address
	 NETNUM T1,T1			; get network number of gateway
	 CAME T1,PRFNET			;is it on our preferred net?
	  TDZA T2,T2			;no
	   MOVEI T2,1			;yes - it gets an extra point
	 ADDI T2,2			;2 or 3 total points
	 RET				;return this value
	MOVEI T2,1			;address is minimally good.

;FNDGAT: Find a gateway (in the gateway table) that is directly connected
;	 to the Network specified (and to a net we are on).
;Entry:	T2/ Network number
;Exit:	+1 failure.  No good gateways were found.
;	+2 success.  T1/ (extended) pointer to gateway block.
MAXGWA==^d50			;this is defined in IPIPIP, only need approx #.
	MOVSI	I,-MAXGWA		; Size of tables
FNDGA0:	HRRZ	GWT,I			; Get offset
	ADD	GWT,GWTAB		; Point into table
	SKIPN	GWT,(GWT)		; Get entry (if any)
	 RET				; Slot is empty - assume end of table
	JE	GWUP,(GWT),FNDGA1 	; Gateway is not up
	MOVE	T1,.GWILS(GWT)		; Get accessable address
	CALL	NETCHK			; Is this interface up?
	 JRST	FNDGA1			; No, try another gateway
	LOAD	T3,GWICT,(GWT)		; Get the interface count
	XMOVEI	T4,.GWILS(GWT)		; Point to interface names
	  MOVE	T1,(T4)			; Get an address
	  NETNUM T1,T1			; Get the net number
	  CAME T1,T2			; Same network as we want?
	   MOVE	T1,GWT			; Get the address of this GW block
	   RETSKP			; and return
	  ADDI T4,1			; Point to the next entry
	  SOJG T3,TOP.			; and loop through this gateway
FNDGA1:	AOBJN	I,FNDGA0		; Loop through all gateway blocks
	RET				;failure.  no skip.
	Subttl	Housecleaning

ifn stansw,<;; reference some symbols so taht they will be accessible in mddt
	ret <logrn+logri+logrp+logue+logua>
>;ifn stansw

	dcheck				;verify values for consistency

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