title	MSUB - assembly language subroutines for pascal

	search	domsym,monsym,macsym

	p=17

;	MAX and MIN

max::	camg 2,3
	 move 2,3
	movem 2,1(p)
	ret

min::	camle 2,3
	 move 2,3
	movem 2,1(p)
	ret

;	functions which are identity functions used to fool the
;	type checking

lckptr::
intptr::
cvtint::	
quotep::
addint::
fbptr::
rmptr::
sbptr::	movem	2,1(p)
	popj	p,

bshift::lsh     2,(3)
        movem	2,1(p)
	popj    p,

band::	and     2,3
	movem	2,1(p)
        popj    p,

bor::   ior     2,3
	movem	2,1(p)
        popj    p,

tbit::	hrlzi	1,400000
	movn	3,3
	lsh	1,0(3)
	tdne	2,1
	 jrst	rtrue
	jrst	rfalse

sbit::	hrlzi	1,400000
	movn	3,3
	lsh	1,0(3)
	iorm	1,0(2)
	ret

aofpag::lsh	2,^d9		; convert page number to address
	movem	2,1(p)
	popj	p,

chrcla::
chrtyp::	movem	2,1(p)
	popj	p,

sizeof::	movem	3,1(p)
	popj	p,

zhhp::	hrrzs	0(2)
	popj	p,

cpyptr::	movem	2,0(4)
	popj	p,

modptr::	add	4,0(2)
		movem	4,0(2)
	popj	p,

blkzero::	sos	,2
		setzm	,0(3)
		movem	3,4
		aos	,4
		extend	2,[	xblt	]
		popj	p,

xxblt::	move 	3,4
	move	1,6
	extend	1,[	xblt	]
	popj	p,

mscloc::time
	movem	1,1(p)
	ret
	
mswait::skiple	1,2
	disms
	ret

;
;	Byte manipulation subroutines
;
;	byte:=	xildb(var ebp)		increment and load byte
;		xidpb(var ebp,value)	increment and deposit
;		xadjbp(var ebp,count)	adjust byte pointer
;		xsetbp(var ebp,base:pointer)	generate G1bpt to first byte
;						of thing base points to

xildb::	ildb	1,0(2)		;load byte
	movem	1,1(p)
	popj	p,

peekb::	ildb	1,2
	movem	1,1(p)
	ret

xildb2::ildb	1,0(2)

xp1:	lsh	1,^d8
	ildb	4,0(2)
	add	1,4
	movem	1,1(p)
	ret

xildb3::ildb	1,0(2)
	call	xp1
	callret	xp1

sildb4::call	xildb4
	lsh	1,4
	ash	1,-4
	movem	1,1(p)
	ret

xildb4::ildb	1,0(2)
	call	xp1
	call	xp1
	callret	xp1

xidpb3::rot	3,^d-16
	idpb	3,0(2)
	rot	3,^d16
	callret	xidpb2

xidpb4::rot	3,^d-16
	call	xidpb2
	rot	3,^d16
xidpb2::rot	3,^d-8
	idpb	3,0(2)
	rot	3,^d8
xidpb::	idpb	3,0(2)		;write byte
	popj	p,

xadjbp::adjbp	3,0(2)		;adjusted byte pointer into 3
	movem	3,0(2)
	popj	p,

xsetbp::and	3,[	7777777777	]	;keep 30 bits
	add	3,[	g1bpt 0,8,0	]
	movem	3,0(2)
	ret

xseto::	and	4,[	7777777777	]	;keep 30 bits
	add	4,[	g1bpt	0,8,0	]
	movem	4,1(p)
	ret

	page
;	function lcomp( var arg1:label_string;
;			var arg2:label_string):integer;
;
;	This routine is used to order labels alphabetically.
;	The integer result of the function is an interger whose sign
;	shows whether arg1 is greater than arg2, + for greater, 0 equal,
;	- for less
;
;	CMPSE registers are:
;
;	1/	string 1 length		(string 1 is arg2) 
;	2+3/	string 1 byte pointer
;	4/	string 2 length		(string 2 is arg1)
;	5+6/	string 2 byte pointer
;
;	function blcomp(    arg1:g1bpt;
;			var arg2:label_string):integer;
;
;	like lcomp except uses a byte pointer for first argument
;

blcomp::move	5,2		;string 2 gets arg 1
	jrst	lmerge

lcomp::	move	6,2		;string 2 gets arg 1
	hrlzi	5,441040	;two word global byte pointer

lmerge:	hrlzi	2,441040
	ildb	1,2		;length of arg2
	ildb	4,5		;length of arg1
	sub	4,1		;excess length of arg1
	push	p,4		;remember excess length
	skipge	4		;skip if arg1 is longer
	 ldb	1,5		;use arg1 length
	move	4,1
	extend	1,[cmpse
			0
			0	]
	 jrst	[	ldb	1,2	;get arg2 character
			ldb	4,5	;get arg1 character
			sub	4,1	;get excess of arg1
			movem	4,0(p)	;replace pushed length delta
			jrst	.+1	]
	pop	p,		;note result stays in proper place
	popj	p,		;for PASCAL return value
		
;	function elcomp(var e_input:exp_label;
;			    c_ptr:dname_pointer):boolean;
;	function belcomp(   e_input:G1bpt;
;			    c_ptr:dname_pointer):boolean;
;
;	function bbelcomp(arg1:G1bpt;
;			  arg2:G1bpt):boolean;

elcomp::	move	6,2
	hrlzi	2,441040
	move	5,2
	push	p,3
	move	3,0(3)
	xmovei	3,ultext(3)
	ildb	1,2
	ildb	4,5
	push	p,1
	push	p,6
	came	1,4
	 jrst	rf3
	extend	1,[cmpse
			0
			0	]
	 jrst	[rf3:	adjsp	p,-3
		rfalse:	setzm	1(p)
			popj	p,	]
	pop	p,6
	xmovei	6,20(6)	; bump past 64 octets of label
	pop	p,1
	pop	p,3
	xmovei	3,1(3)
	move	4,1
	hrlzi	2,440140
	move	5,2
	extend	1,[cmpse
			0
			0	]
	 jrst	rfalse
rtrue:	movei	1,1
	movem	1,1(p)
	popj	p,

belbp:	g2bpt	0,1,dlabel+casemo

belcomp::move	4,dlabel+labptr(3)	;get address of ulabel
	add	4,[	g1bpt	0,8,ultext	]	;byte pointer (text)
	move	5,belbp
	move	6,belbp+1
	add	6,3

	ildb	7,2		;first length
	ildb	1,4

	came	7,1
	 jrst	rfalse		;failure if lengths different
	jumpe	7,rtrue		;success if zero lengths to compare

bell:	ildb	7,4		;get byte from dname
	ildb	10,5		;get case modifier bit
	skipe	10
	 addi	7,"z"-"Z"
	ildb	10,2		;get other comparand
	came	7,10
	 jrst	rfalse
	sojn	1,bell
	move	3,more(3)	;move on to next chunk of dname
	jrst	belcomp

bbelcomp::
	move	5,3
	ildb	1,2
	ildb	4,5
	came	1,4
	 jrst	rfalse
	extend	1,[cmpse
			0
			0]
	 jrst	rfalse
	jrst	rtrue
	page
;	function hashls(var arg:label_string):label_hashrange;
;	function bhash(arg:g1bpt);

bhash::	skipa	1,2
hashls::hrlzi	1,441040

	ildb	3,1
	move	4,3

hlslp:	sojl	3,hlsdon
	ildb	5,1
	lsh	5,6
	add	4,5

	sojl	3,hlsdon
	ildb	5,1
	add	4,5
	jrst	hlslp

hlsdon:	idivi	4,labelh
	movem	5,1(p)

	popj	p,
	page
;	function lendns(ebp:g1bpt):integer
;
;	returns length in bytes of domain string
lendns::setzm	3

ldlp:	ildb	4,2
	add	3,4		;add in label length
	aos	3		;plus one octet for count
	jumpe	4,[	movem	3,1(p)
			ret	]
	adjbp	4,2
	move	2,4
	jrst	ldlp

;	procedure copyls(from_ls:g1bpt;
;			 to_ls:g1bpt);
copyls::move	5,3
	ildb	1,2
	idpb	1,5
	move	4,1
	extend	1,[movslj
			0	]
	 haltf
	popj	p,
;
;	copydns(from:g1bpt;
;		dest:g1bpt)
;
;	copy domain string
;

copydns::move	5,3
cpyd:	ildb	1,2
	idpb	1,5
	skipn	1
	 popj	p,
	move	4,1
	extend	1,[movslj
			0	]
	 haltf
	jrst	cpyd
;
;	ccls(from:g1bpt;
;	      dest:g1bpt)
;
;	copy label string while standardizing case
;

ccls::	ildb	4,2	;get length of source
	idpb	4,3	;store it
	skipn	4
	 popj	p,	;return if done
cclsl:	ildb	5,2
	caige	5,"a"
	 jrst	clsto
	caig	5,"z"
	 subi	5,"z"-"Z"
clsto:	idpb	5,3
	sojn	4,cclsl
	popj	p,
;
;	ccdns(from:g1bpt;
;	      dest:g1bpt)
;
;	copy domain string while standardizing case
;

ccdns::	ildb	4,2	;get length of source
	idpb	4,3	;store it
	skipn	4
	 popj	p,	;return if done
	call	cclsl
	jrst	ccdns
	page
;
;	ccopy(var from:g1bpt;
;	      var dest:g1bpt;
;		  length:integer)
;
ccopy::	jumpe 4,ccopyr
ccopyl:	ildb 5,@2
	idpb 5,@3
	sojn 4,ccopyl
ccopyr:	ret
;
;	function ccomp(str1:g1bpt,str2:g1bpt,length:integer)
;
ccomp::	move	5,3
	move	1,4
	extend	1,[cmpse
			0
			0]
	 jrst	rfalse
	jrst	rtrue
	page
;
;	function dnscomp(op1:g1bpt;
;			 op2:g1bpt):boolean
;
;	This function compares the two domain names
;	and returns true iff they are the same, ignoring case
;
dnscomp::ildb	4,2
	ildb	5,3
	came	4,5		;compare label lengths
	 jrst	rfalse		;can't be the same if lengths differ
	jumpe	4,rtrue		;success if got to root

dnsll:	ildb	5,2		;get char from first string
	ildb	6,3		;get char from second string
	camn	5,6
	 jrst	dnsllg		;characters equal without case fudging

	caige	5,"a"		;see if character from string 1 is lower case
	 jrst	dnsc2
	caig	5,"z"
 	 subi	5,"a"-"A"	;fix it if so
				
dnsc2:	caige	6,"a"		;check character from second string
	 jrst	dnsc3
	caig	6,"z"
 	 subi	6,"a"-"A"

dnsc3:	came	5,6
	 jrst	rfalse
dnsllg:	sojn	4,dnsll		;loop through all characters in label
	jrst	dnscomp
	page

xaos::	aos	0(2)
	ret
	subttl	Locking code
;	function prlock(var mylock:lock):boolean
;
;	procedure pulock(var mylock:lock)
;
;	procedure ilock(var mylock:lock)
;
prlock::aose	lockwd(2)
	 jrst	rfalse
	jrst	rtrue

pulock::setom	lockwd(2)
	ret

ilock::	setom	lockwd(2)
	setzm	share(2)
	setzm	exclus(2)
	ret
;
;	function locks(var mylock:lock;
;			   deltat:integer;
;			   timeout:integer):boolean;extern;
;	function locke(var mylock:lock;
;			   deltat:integer;
;			   timeout:integer):boolean;extern;
locks::	aose	lockwd(2)	;try primitive lock
	 jrst 	locksw		;if can't get primitive, go wait
	skipn	exclus(2)	;skip exclusive locks set
	 jrst	[	aos	share(2)
			setom	lockwd(2)
			jrst	rtrue	]
	setom	lockwd(2)	;release primitive lock
locksw:	sub	4,3		;decrement timeout
	jumpl	4,rfalse	;fail if less
	move	1,3		;otherwise wait
	disms
	jrst	locks	

locke::	aose	lockwd(2)	;try primitive lock
	 jrst 	lockew		;if can't get primitive, go wait
	skipn	exclus(2)	;skip exclusive locks set
	 jrst	[	skipe	share(2)
			 jrst	.+1
			aos	exclus(2)
			setom	lockwd(2)
			jrst	rtrue	]
	setom	lockwd(2)	;release primitive lock
lockew:	sub	4,3		;decrement timeout
	jumpl	4,rfalse	;fail if less
	move	1,3		;otherwise wait
	disms
	jrst	locke	

;	procedure ulocks(var mylock:lock);extern;
;	procedure ulocke(var mylock:lock);extern;

ulocks::sos	share(2)
	ret

ulocke::sos	exclus(2)
	ret

	end