.title	SNOBOL4
	.ident	/27JAN82/
;
; Welcome to the VAX 11 Snobol4 System.
;

expreg	=	250	; number of pages in the allocated data region
			; 250 pages = 16,000 descriptors

;  This system consists of n files, where n is an integer.  They are:
;
;	m.mar		This file, it is the 130 macro definitions 
;			required to transform the Snobol Sil source 
;			code into a working monster.
;
;	output.mar	A fortran-like output conversion routine used
;			only by output, stread, and stprnt macros.
;
;	syntax.tbl	The syntax tables.
;
;	stream.mar	The parser for the syntax tables.
;			Called only by the stream macro.
;
;	snobol.sil	The real thing.  Changes to the source are:
;			  Put ':' after labels
;			  Change END to .END
;			  Change column 1 '*' to ';'
;			  Put ';' before comments in column 32
;			  Put <> around strings and multiple arguments
;			    passed to macros
;			  Change label 'DV' at 001914 to 'DVQ:' since dv in
;			    macro means the divide interrupt vector
;			  At label OBEND at line 005437 change:
;			    oblist+descr*oboff   to
;			    descr*oboff+oblist
;			  Change TITLEs to .page and .sbttl
;			  Add .psects at various places
;			
;			
	.page
;****************************************
;*					*
;*	copy parms data follows		*
;*					*
;****************************************

;
; offsets to descriptor block fields
;
;       BIT
;   	 31	24	16	8      0
;	!-------------------------------!
;	!	     ADDRESS		! : a
;	!-------------------------------!
;	! FLAGS !	 VALUE		!  : a+4
;	!-------------------------------!
;
d.a==0	; address field
d.vv=4	; v field ( for regular offset use)
d.v=4*8	; value field (for use in field instructions)
d.vl=24.; length (in bits) of v field (for use in field instructions)
d.f=7	; flag field
descr=8	; length of descriptor block

;
; additional offsets to spec block
;
;       BIT
;  	 31	24	16	8      0
;	!-------------------------------!
;	!	     ADDRESS		! : a
;	!-------------------------------!
;	! FLAGS !	 VALUE		!  : a+4
;	!-------------------------------!
;	!	     OFFSET		! : a+8
;	!-------------------------------!
;	!	     LENGTH		! : a+12
;	!-------------------------------!
;
s.o==8	; offset field
s.l==12.; length field
spec=16.; length of specifier block

	.page
;
; more equates
;
fnc	=	^x02			; function
mark	=	^x04			; marked titles
ptr	=	^x08			; pointer to dynamic storage
sttl	=	^x10			; string titles
ttl	=	^x20			; block title
cpa	=	1			; characters per addressing unit
cpd	=	8			; characters per descriptor
uniti	=	5			; input device number
unito	==	6			; output device number
unitp	=	7			; punch device number
sizlim	=	^x00ffffff		; largest integer in a v field
alphsz	=	128.			; number of characters in char set


;
; Examples of V and F field manipulations:
;
;	bisb2	#fnc,#descr+d.f		; Set FNC flag in descr
;	
;	extzv	#d.v,#d.vl,descr,r3	; Get V field into r3
;	insv	r3,#d.v,#d.vl,descr	; Put v field from r3 into descr
;



	.psect	snobol4,shr,wrt,long
;	    directive shr means that the psect is non-copy-on-reference	
;	    it does not get copied to the swapping file upon being activated.
;

;
;    externals defined in output
;
	.external	quqdesc,f1a132,f1x1a132

;
;    syntab index entries for clertb,plugtb
;
	.external	contin,error,stop,stopsh

;
;  external syntax table names
;
	.external	bioptb,cardtb,dqlitb,elemtb,eostb,flitb,frwdtb
	.external	gotftb,gototb,gotstb,iblktb,intgtb,lbltb,lblxtb
	.external	nblktb,numbtb,numctb,snabtb,sqlitb,startb,tblktb
	.external	unoptb,varatb,varbtb,vartb

;
;   stuff defined here referenced elsewhere
;
	.global	stype	; in stream subroutine

;
;   function names used in syntax tables
;
	.global	bipdfn,dolfn,biprfn,addfn,subfn,namfn,divfn,biatfn
	.global	mpyfn,expfn,pdfn,indfn,prfn,keyfn,strfn,mnsfn,dotfn
	.global	slhfn,quesfn,atfn,negfn,orfn
	.global arowfn,barfn,biamfn,bingfn,biqsfn,plsfn

	.page
;****************************************
;*					*
;*	support macros follow		*
;*					*
;****************************************
.macro	mcase	a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,?a,?x,?z
	.narg	nargs
	.if ne nargs		; do nothing if no args
	tstl	r2
	beql	x		; 
	bgtr	a		; return value
	halt
a:	cmpl	r2,#nargs
	bgtr	x		; return value=m+1
	decl	r2
	movl	z[r2],r1
	jmp	(r1)
	.align	long
z:	xxxx=0
	.irp	val,<a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12>
	.iif nb,val,	.long	val
	.iif b,val,	.long	x
	xxxx=xxxx+1
	.iif le nargs-xxxx,.mexit
	.endm
	.endc
x:
	.endm





.macro	gel	gt,eqb,ltb,?a,?b,?c
	.if nb gt
$$$=1
	.if defined gt
	.if lt .-gt-127.
$$$=0
	.endc
	.endc
	.if eq $$$
	bgtr	gt
	.iff
	bleq	a
	jmp	gt
a:	nop
	.endc
	.endc

	.if nb eqb
$$$=1
	.if defined eqb
	.if lt .-eqb-127.
$$$=0
	.endc
	.endc
	.if eq $$$
	beql	eqb
	.iff
	bneq	b
	jmp	eqb
b:	nop
	.endc
	.endc

	.if nb ltb
$$$=1
	.if defined ltb
	.if lt .-ltb-127.
$$$=0
	.endc
	.endc
	.if eq $$$
	blss	ltb
	.iff
	bgeq	c
	jmp	ltb
c:	nop
	.endc
	.endc
	.endm

.macro	nebr	neb,eqb,?a,?b
	.if nb neb
$$$=1
	.if defined neb
	.if lt .-neb-127.
$$$=0
	.endc
	.endc
	.if eq $$$
	bneq	neb
	.iff
	beql	a
	jmp	neb
a:	nop
	.endc
	.endc

	.if nb eqb
$$$=1
	.if defined eqb
	.if lt .-eqb-127.
$$$=0
	.endc
	.endc
	.if eq $$$
	beql	eqb
	.iff
	bneq	b
	jmp	eqb
b:	nop
	.endc
	.endc
	.endm


	.page
;****************************************
;*					*
;*	  sil macros follow		*
;*					*
;****************************************
;
; notes on the macros that follow:
;	'Implementing SNOBOL4 in SIL' terminology is used, not the book terms.
;	register usage:
;		r0 - work reg & top of returned descriptor in rreturn
;		r1 - work reg & bottom of returned descriptor in rreturn
;		r2 - work reg & index to mcase macro jump table
;		r3 - work reg & return descriptor indicator in rreturn
;		r4 - work reg
;		r5 - work reg
;		r6 - work reg
;		r7 - work reg
;		r8 - work reg
;		r9 - work reg
;		r10 - old stack pointer
;		r11 - current stack pointer


.macro	acomp	descr1,descr2,gtb,eqb,ltb
	cmpl	descr1+d.a,descr2+d.a	; compare address fields
	gel	gtb,eqb,ltb
	.endm
 

.macro	acompc	descr,n,gtb,eqb,ltb
	cmpl	descr+d.a,#n	; compare address with constant
	gel	gtb,eqb,ltb
	.endm


.macro	addlg	spec,descr
	addl2	descr+d.a,spec+s.l
	.endm


.macro	addsib	descr1,descr2
	movl	descr1+d.a,r1
	movl	descr2+d.a,r2
	movl	father(r1),r3
	movq	rsib(r1),rsib(r2)
	movq	father(r1),father(r2)
	movq	descr2,rsib(r1)
	extzv	#d.v,#d.vl,code(r3),r4
	incl	r4
	insv	r4,#d.v,#d.vl,code(r3)
	.endm


.macro	addson 	descr1,descr2
	movl	descr1+d.a,r1		; r1->a1
	movl	descr2+d.a,r2		; r2->a2
	movq	descr1,father(r2)
	movq	lson(r1),rsib(r2)
	movq	descr2,lson(r1)
	extzv	#d.v,#d.vl,code(r1),r4
	incl	r4
	insv	r4,#d.v,#d.vl,code(r1)
	.endm


.macro	adjust	descr1,descr2,descr3
	movl	descr2+d.a,r2
	addl3	descr3+d.a,(r2),descr1+d.a
	.endm


.macro	adreal 	descr1,descr2,descr3,fail,succ
	addf3	descr2+d.a,descr3+d.a,r1
	movf	r1,descr1+d.a
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm
 

.macro	aeql	descr1,descr2,neb,eqb
	cmpl	descr1+d.a,descr2+d.a
	nebr	neb,eqb
	.endm


.macro	aeqlc	descr1,n,neb,eqb
	cmpl	descr1+d.a,#n
	nebr	neb,eqb
	.endm


.macro	aeqlic 	descr,n1,n2,neb,eqb
	movl	descr+d.a,r1
	cmpl	n1(r1),#n2
	nebr	neb,eqb
	.endm


.macro	apdsp  	spec1,spec2
	addl3	spec1+d.a,spec1+s.o,r6
	addl2	spec1+s.l,r6
	addl3	spec2+d.a,spec2+s.o,r7
	movc3	spec2+s.l,(r7),(r6)
	addl2	spec2+s.l,spec1+s.l
	.endm


.macro	array	leng
	.nlist
	.rept	leng
	.quad	0
	.endr
	.list
	.endm


.macro	bksize 	descr1,descr2,?set,?end
	movl	descr2+d.a,r1
	bitb	#sttl,d.f(r1)
	bneq	set
	extzv	#d.v,#d.vl,(r1),r2
	addl3	r2,#descr,descr1+d.a
	brb	end
set:					;f(v)=d*(4+[(v-1)/cpd+1])
	extzv	#d.v,#d.vl,(r1),r2	; get v field
	decl	r2			; 	     (v-1)
	ashl	#-3,r2,r2		; 	     (v-1)/cpd
	addl2	#5,r2			; 	 (4+[(v-1)/cpd+1])
	ashl	#3,r2,descr1+d.a	; f(v)=d*(4+[(v-1)/cpd+1])
end:
	clrl	descr1+d.vv
	.endm


.macro	bkspce 	descr
	pushl	descr+d.a
	calls	#1,for$backspace
	.endm


.macro	branch 	loc,proc
	jmp	loc
	.endm


.macro	branic	descr,n
;
;	branch to code pointed to by descr d indexed by n
;
	.iif ne n,.error - n is not zero
	movl	descr+d.a,r1
	jmp	@(r1)
	.endm


.macro	buffer 	len
	.nlist
	.rept	len
	.ascii	/ /
	.endr
	.list
	.even
	.endm


.macro	chkval 	descr1,descr2,spec,gtb,eqb,ltb
	addl3	spec+s.l,descr2+d.a,r1
	cmpl	r1,descr1+d.a
	gel	gtb,eqb,ltb
	.endm
 

.macro	clertb	table,key,?loop
;
;	clear table on condition key
;
	.if idn,key,CONTIN
	movb	#contin,r0	; set up for continue synt entry
	.endc
	.if idn,key,ERROR
	movb	#error,r0	; set up for error entry
	.endc
	.if idn,key,STOP
	movb	#stop,r0
	.endc
	.if idn,key,STOPSH
	movb	#stopsh,r0
	.endc
	clrl	r1			; put value = 0
	clrl	r2
loop:	movb	r0,table[r2]		; make table entry
	aobleq	#128,r2,loop
	.endm


.macro	copy   	p1
;
	.if idn,p1,MDATA
alpha:	.byte	^x00,^x01,^x02,^x03,^x04,^x05,^x06,^x07,^x08,^x09,^x0a,^x0b,^x0c,^x0d,^x0e,^x0f
	.byte	^x10,^x11,^x12,^x13,^x14,^x15,^x16,^x17,^x18,^x19,^x1a,^x1b,^x1c,^x1d,^x1e,^x1f
	.byte	^x20,^x21,^x22,^x23,^x24,^x25,^x26,^x27,^x28,^x29,^x2a,^x2b,^x2c,^x2d,^x2e,^x2f
	.byte	^x30,^x31,^x32,^x33,^x34,^x35,^x36,^x37,^x38,^x39,^x3a,^x3b,^x3c,^x3d,^x3e,^x3f
	.byte	^x40,^x41,^x42,^x43,^x44,^x45,^x46,^x47,^x48,^x49,^x4a,^x4b,^x4c,^x4d,^x4e,^x4f
	.byte	^x50,^x51,^x52,^x53,^x54,^x55,^x56,^x57,^x58,^x59,^x5a,^x5b,^x5c,^x5d,^x5e,^x5f
	.byte	^x60,^x61,^x62,^x63,^x64,^x65,^x66,^x67,^x68,^x69,^x6a,^x6b,^x6c,^x6d,^x6e,^x6f
	.byte	^x70,^x71,^x72,^x73,^x74,^x75,^x76,^x77,^x78,^x79,^x7a,^x7b,^x7c,^x7d,^x7e,^x7f
;;;;;	.byte	^x80,^x81,^x82,^x83,^x84,^x85,^x86,^x87,^x88,^x89,^x8a,^x8b,^x8c,^x8d,^x8e,^x8f
;	.byte	^x90,^x91,^x92,^x93,^x94,^x95,^x96,^x97,^x98,^x99,^x9a,^x9b,^x9c,^x9d,^x9e,^x9f
;	.byte	^xa0,^xa1,^xa2,^xa3,^xa4,^xa5,^xa6,^xa7,^xa8,^xa9,^xaa,^xab,^xac,^xad,^xae,^xaf
;	.byte	^xb0,^xb1,^xb2,^xb3,^xb4,^xb5,^xb6,^xb7,^xb8,^xb9,^xba,^xbb,^xbc,^xbd,^xbe,^xbf
;	.byte	^xc0,^xc1,^xc2,^xc3,^xc4,^xc5,^xc6,^xc7,^xc8,^xc9,^xca,^xcb,^xcc,^xcd,^xce,^xcf
;	.byte	^xd0,^xd1,^xd2,^xd3,^xd4,^xd5,^xd6,^xd7,^xd8,^xd9,^xda,^xdb,^xdc,^xdd,^xde,^xdf
;	.byte	^xe0,^xe1,^xe2,^xe3,^xe4,^xe5,^xe6,^xe7,^xe8,^xe9,^xea,^xeb,^xec,^xed,^xee,^xef
;	.byte	^xf0,^xf1,^xf2,^xf3,^xf4,^xf5,^xf6,^xf7,^xf8,^xf9,^xfa,^xfb,^xfc,^xfd,^xfe,^xff

ampst:	.ascii	/&/
colstr:	.ascii	/: /
qtstr:	.ascii	/'/
	.endc
	.endm


.macro	cpypat	descr1,descr2,descr3,descr4,descr5,descr6,?loop,?a,?b,?c,?e
	movl	descr1+d.a,r1
	movl	descr2+d.a,r2
	movl	descr6+d.a,r3
					; copy a section
loop:	movq	descr(r2),descr(r1)	; copy first descriptor
	movl	descr*2(r2),r0		; copy second descriptor
	beql	a			; f1(x)
	addl2	descr4+d.a,r0
a:	movl	r0,descr*2(r1)
	extzv	#d.v,#d.vl,2*descr(r2),r0
	beql	b			; f2(x)
	addl2	descr4+d.a,r0
	brb	c
b:	movl	descr5+d.a,r0
c:	insv	r0,#d.v,#d.vl,descr*2(r1)
	movb	2*descr+d.f(r2),2*descr+d.f(r1)

	addl3	descr*3(r2),descr3+d.a,descr*3(r1) ; copy third descriptor
	extzv	#d.v,#d.vl,3*descr(r2),r0
	addl2	descr3+d.a,r0
	insv	r0,#d.v,#d.vl,descr*3(r1)
	movb	2*descr+d.f(r2),2*descr+d.f(r1)

	extzv	#d.v,#d.vl,descr(r2),r7
	cmpl	r7,#3
	bneq	e
	movq	descr*4(r2),descr*4(r1)	; copy fourth descriptor
e:
	incl	r7			;    (1+v7)
	ashl	#3,r7,r7		;    (1+v7)*d
	addl2	r7,r1			; r1+(1+v7)*d
	addl2	r7,r2			; r2+(1+v7)*d
	subl2	r7,r3			; r3-(1+v7)*d
	bgtr	loop
	movl	r1,descr1+d.a
	 .endm


.macro	date   	spec,?a,?buf
;
;	generate descr->mm:dd:yy
;
	$asctim_s timbuf=buf
	moval	buf+8,spec+d.a		; spec->date buffer
	movl	#23,spec+s.l		; length of buffer
	clrl	spec+d.vv
	clrl	spec+s.o
	brb	a
buf:	.long	23
	.long	buf+8
	.blkb	23
a:	.endm


.macro	decra	descr,n
	subl2	#n,descr+d.a
	.endm


.macro	deql	descr1,descr2,neb,eqb,?a
;
;	if d1 <> d2 goto ne
;	if d1 == d2 goto eq
;	quad compare
;
	cmpl	descr1,descr2
	.iif nb,neb,	nebr	neb
	.iif b,neb,	bneq	a
	cmpl	descr1+d.vv,descr2+d.vv
	nebr	neb,eqb
a:
	.endm
 

.macro	descr	a=0,f=0,v=0
;
;	descriptor
;
	.long	a
	.long	<f>*^x01000000+v
	.endm


.macro	divide	descr1,descr2,descr3,fail,succ,?a
	.if nb fail
	tstl	descr3+d.a
	bneq	a
	jmp	fail			; divide by zero
	.endc
a:	divl3	descr3+d.a,descr2+d.a,descr1+d.a
	movl	descr2+d.vv,descr1+d.vv
	.if nb succ
	jmp	succ
	.endc
	.endm



.macro	dvreal 	descr1,descr2,descr3,fail,succ,?a
	.if nb,fail
	tstf	descr3+d.a
	bneq	a
	jmp	fail
a:
	.endc
	divf3	descr3+d.a,descr2+d.a,r1
	movf	r1,descr1+d.a
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.if nb,succ
	jmp	succ
	.endc
	.endm


.macro	endex	descr
	; if descr+d.a=1 then produce post-mortem dump
	$exit_s		; return to system
	.endm


.macro	enfile 	descr
	pushl	descr+d.a
	calls	#1,for$endfile
	.endm


.macro	expint 	descr1,descr2,descr3,fail,succ
	pushl	descr3		; push exponent
	pushl	descr2		; push base
	calls	#2,g^ots$powjj
	movl	r0,descr1	; base ** exponent
	.iif dif,descr1,descr2,	movl	descr2+d.v,descr1+d.v
	.iif nb,succ,	jmp	succ
	.endm


.macro	exreal	descr1,descr2,descr3,fail,succ
	movf	descr3,-(sp)	; push exponent
	movf	descr2,-(sp)	; and base
	calls	#2,g^ots$powrr
	movf	r0,descr1	; base ** exponent
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	format	strng
	.nchr	z,<strng>
	.save_psect
	.psect	string,shr,nowrt
$$$=.
	.ascii	"strng"
	.restore_psect

	;string descriptor (vax format)
	.word	z	; number of characters
	.byte	14	; class
	.byte	1	; type
	.long	$$$	; address of string
	.endm


.macro	fshrtn 	spec,n
	addl2	#n,spec+s.o
	subl2	#n,spec+s.l
	.endm


.macro	getac	descr1,descr2,n
	movl	descr2+d.a,r2
	movl	n(r2),descr1+d.a
	.endm


.macro	getbal 	spec,descr,fail,succ,?bal1,?b2,?b3,?found,?error,?end
	addl3	spec+d.a,spec+s.o,r1
	addl2	spec+s.l,r1
	clrl	r0		; char count
	tstl	descr+d.a
	beql	found
	clrl	r2		; nest depth count
	cmpb	(r1)[r0],#^a/(/	; is first char a '(' ?
	beql	bal1		; brifnot
	cmpb	(r1)[r0],#^a/)/	; is it a ')' ?
	beql	error
	incl	r0		; match a single character
	brb	found
bal1:
	cmpl	r0,descr+d.a
	bgeq	error
	cmpb	(r1)[r0],#^a/(/
	bneq	b2
	incl	r2
	brb	b3
b2:	cmpb	(r1)[r0],#^a/)/
	bneq	b3
	incl	r0
	decl	r2
	beql	found
	blss	error
	brb	bal1
b3:	incl	r0
	brb	bal1
error:	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
found:	addl2	r0,spec+s.l
	.iif nb,succ,	jmp	succ
end:	
	.endm


.macro	getd   	descr1,descr2,descr3
;
;	get descr: d1= descr at addr(d2.v + d3.v)
;
	addl3	descr2+d.a,descr3+d.a,r2
	movq	(r2),descr1
	.endm


.macro	getdc  	descr1,descr2,n
;
;	get descr: d1= descr at addr(d2.v + const)
;
	addl3	descr2+d.a,#n,r2
	movq	(r2),descr1
	.endm


.macro	getlg	descr,spec
	movl	spec+s.l,descr+d.a
	clrl	descr+d.vv
	.endm


.macro	getlth 	descr1,descr2
	movl	descr2+d.a,r2		;	      l
	decl	r2			;	     (l-1)
	ashl	#-3,r2,r2		;	     (l-1)/cpd
	addl	#3+1,r2			;	 (3+[(l-1)/cpd+1])
	ashl	#3,r2,descr1+d.a	; f(l)=d*(3+[(l-1)/cpd+1])
	clrl	descr1+d.vv
	.endm


.macro	getsiz	descr1,descr2
	movl	descr2+d.a,r2
	extzv	#d.v,#d.vl,(r2),descr1+d.a
	clrl	descr1+d.vv
	.endm


.macro	getspc	spec,descr,n
	movl	descr+d.a,r2
	movq	n(r2),spec
	movq	n+s.o(r2),spec+s.o
	.endm


.macro	incra	descr,n
	addl2	#n,descr+d.a
	.endm


.macro	incrv	descr,n
;
;	d1.v=d1.v+inc
;
	extzv	#d.v,#d.vl,descr,r3	; get v field into r3
	addl2	#n,r3
	insv	r3,#d.v,#d.vl,descr	; put v field from r3 into descr
	.endm


.macro	init	null1,null2,?a,?b,?c
	.entry	start,^m<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>
	clrl	r0
	movzbl	#8,r8		; initialize the registers
;;;;;;	$lkwset_s a			; keep pattern and system stacks
	brb	b			; in the working set
a:	.long	pdlblk
	.long	stack+descr*stsize
c:	.long	0
	.long	0
b:	$expreg_s pagcnt=#expreg,retadr=c,region=#0 ; get 250 pages
	movl	c,frsgpt	; set up garbage collect varbls
	movl	c,hdsgpt
	bicl3	#^x0f,c+4,tlsgp1
	.endm


.macro	insert	descr1,descr2
	movl	descr1+d.a,r1
	movl	descr2+d.a,r2
	movl	father(r1),r3
	movl	lson(r3),r4
	movq	descr1,lson(r2)
	movq	father(r1),father(r2)
	movq	descr2,rsib(r4)
	movq	descr2,father(r1)
	extzv	#d.v,#d.vl,code(r2),r3	; Get V field into r3
	incl	r3
	insv	r3,#d.v,#d.vl,code(r2)	; Put v field from r3 into descr
	.endm


.macro	intrl 	descr1,descr2
	cvtlf	descr2+d.a,descr1+d.a
	clrb	descr1+d.f
	movl	#r,r1
	insv	r1,#d.v,#d.vl,descr1
	.endm


.macro	intspc	spec,descr,?q,?b,?c,?d,?e
	pushal	q
	pushal	descr+d.a
	calls	#2,g^ots$cvt_l_ti	; call convert routine
	brb	b
q:	.word	11	; length
	.byte	14
	.byte	1
	.long	c	; address
c:	.ascii	/+9999999999/
b:	clrl	spec+d.vv
	clrl	spec+s.o
	moval	c,r1			; r1->blanks
e:	cmpb	(r1),#^a/ /		; is it a blank?
	bneq	d			; brifnot
	incl	r1
	brb	e
d:	movl	r1,spec+d.a
	subl3	r1,#c+11,spec+s.l	; length of string
	.endm


.macro	istack	null1,null2
	moval	stack+descr,r11
	clrl	r10
	.endm


.macro	lcomp	spec1,spec2,gtb,eqb,ltb
	cmpl	spec1+s.l,spec2+s.l	
	gel	gtb,eqb,ltb
	.endm


.macro	leqlc	spec,n,neb,eqb
	cmpl	spec+s.l,#n
	nebr	neb,eqb
	.endm
 

.macro	lexcmp	spec1,spec2,gtb,eqb,ltb
	addl3	spec1+d.a,spec1+s.o,r6
	addl3	spec2+d.a,spec2+s.o,r7
	cmpc5	spec1+s.l,(r6),#0,spec2+s.l,(r7)
	gel	gtb,eqb,ltb
	.endm


.macro	lhere	null1,null2
	.endm


.macro	link   	descr1,descr2,descr3,descr4,fail,succ
;
;	access external function
;
	jmp	intr10		; disabled: extermal functions
;
;	movl	descr3,r0	; no of args
;	movl	descr2,r1	; addr of args
;	calls	#0,@descr4	; call the sub
;	tst	r3
;	beql	a
;	movq	r0,descr1
;a:
	.endm


.macro	linkor 	descr1,descr2,?loop,?exit
	addl3	descr1+d.a,#descr*2,r1
	movl	r1,r2
loop:	tstl	(r1)
	beql	exit		; brifdone
	addl3	(r1),r2,r1
	brb	loop
exit:	movl	descr2+d.a,(r1)
	.endm


.macro	load   	descr,spec1,spec2,fail,succ
;
;	load external function
;
	jmp	undf		; disabled: external functions
;
;lbl:	$fab	fnm=<?????.exe>,fop=ufo,fac=put
;maprange: .long ?,?
;retrange: .long ?,?
;	$open	fab=lbl
;	$crmpsc_s inadr=maprange,...
;
	.endm


.macro	locapt 	descr1,descr2,descr3,fail,succ,?loop,?skip,?end,?a
	movl	descr2+d.a,r2		; ptr down list
	extzv	#d.v,#d.vl,(r2),r3	; final counter
	addl3	r2,r3,r4		; limit reg
loop:	cmpl	descr(r2),descr3
	bneq	a
	cmpl	descr+d.vv(r2),descr3+d.vv
	beql	skip
a:	acbl	r4,#descr*2,r2,loop
	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
skip:	movl	r2,descr1+d.a
	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
end:
	.endm


.macro	locapv 	descr1,descr2,descr3,fail,succ,?loop,?skip,?end,?a
	movl	descr2+d.a,r2		; ptr down list
	extzv	#d.v,#d.vl,(r2),r3	; final counter
	addl3	r2,r3,r4		; limit reg
	ashl	#-4,r3,r3		; get integer counter
loop:	cmpl	2*descr(r2),descr3
	bneq	a
	cmpl	2*descr+d.vv(r2),descr3+d.vv
	beql	skip
a:	acbl	r4,#descr*2,r2,loop
	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
skip:	movl	r2,descr1+d.a
	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
end:
	.endm


.macro	locsp	spec,descr,?skip,?zero
	movl	descr+d.a,r1
	beql	zero
	movq	descr,spec
	movl	#4*cpd,spec+s.o
	extzv	#d.v,#d.vl,(r1),spec+s.l
	brb	skip
zero:	clrl	spec+s.l
skip:
	.endm


.macro	lvalue 	descr1,descr2,?a,?out,?loop
	movl	descr2+d.a,r2
	movl	3*descr+d.a(r2),r1	; get first value
loop:	cmpl	3*descr+d.a(r2),r1
	bgequ	a
	movl	3*descr+d.a(r2),r1
a:	movl	2*descr+d.a(r2),r2
	beql	out
	addl2	descr2+d.a,r2
	brb	loop
out:	movl	r1,descr1+d.a
	clrl	descr1+d.vv
	.endm


.macro	maknod 	descr1,descr2,descr3,descr4,descr5,descr6
	movq	descr2,r0	; r0,r1=descr2
	movq	descr5,1*descr(r0)
	movl	descr4+d.a,2*descr(r0)
	movl	descr3+d.a,3*descr(r0)
	.if nb,descr6
	movq	descr6,4*descr(r0)
	.endc
	movq	r0,descr1
	.endm


.macro	mnreal 	descr1,descr2
	mnegf	descr2+d.a,descr1+d.a
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.endm


.macro	mnsint	descr1,descr2,fail,succ,?a
	mnegl	descr2+d.a,descr1+d.a
	.if nb,fail
	bvc	a
	jmp	fail
a:	
	.endc
	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	mova   	descr1,descr2
	movl	descr2+d.a,descr1+d.a
	.endm


.macro	movblk	descr1,descr2,descr3
	movl	descr1+d.a,r6
	movl	descr2+d.a,r7
	movl	descr3+d.a,r8
	movc	r8,descr(r7),descr(r6)
	.endm


.macro	movd	descr1,descr2
	movq	descr2,descr1
	.endm


.macro	movdic	descr1,n1,descr2,n2
	movl	descr1+d.a,r1
	movl	descr2+d.a,r2
	movq	n2(r2),n1(r1)
	.endm


.macro	movv	descr1,descr2
;
;	d1.v := d2.v
;
	movc3	#3,descr2+d.vv,descr1+d.vv
	.endm


.macro	mpreal 	descr1,descr2,descr3,fail,succ
	mulf3	descr2+d.a,descr3+d.a,r1
	movf	r1,descr1+d.a
	.iif dif,descr2,descr1,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	mstime 	descr,?list,?tim,?a
	.iif ndf,jpi$_cputim,	$jpidef
	$getjpi_s ,,,list
	mull2	#10,tim
	movl	tim,descr+d.a
	clrl	descr+d.vv
	brb	a
list:	.word	4		; longword data
	.word	jpi$_cputim	; what we want
	.long	tim		; addr of buffer
	.long	0		; no length
tim:	.blkl	1
a:
	.endm


.macro	mult	descr1,descr2,descr3,fail,succ,?a
	mull3	descr3+d.a,descr2+d.a,r1
	.if nb,fail
	bvc	a
	jmp	fail
a:	
	.endc
	movl	r1,descr1+d.a
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	multc	descr1,descr2,n
	mull3	descr2+d.a,#n,descr1+d.a
	clrl	descr1+d.vv
	.endm


.macro	ordvst 	
	; disabled: alphabetization of post-mortem dump
	.endm


.macro	output 	descr,format,iolist
	.narg	nargs
$$$=1
	outhlp	iolist
	pushal	format
	calls	#$$$,quqout
	.endm

.macro	outhlp	descr1,descr2,descr3,descr4,descr5,descr6,descr7
	.irp	val,<descr7,descr6,descr5,descr4,descr3,descr2,descr1>
	.if nb,val
	pushl	val
$$$=$$$+1
	.endc
	.endr
	.endm


.macro	plugtb 	table,key,spec,?loop,?exit
	.if idn,key,CONTIN
	movb	#contin,r0	; set up for continue synt entry
	.endc
	.if idn,key,ERROR
	movb	#error,r0	; set up for error entry
	.endc
	.if idn,key,STOP
	movb	#stop,r0
	.endc
	.if idn,key,STOPSH
	movb	#stopsh,r0
	.endc
	clrl	r1			; put value = 0
	addl3	spec+d.a,spec+s.o,r3	; char pointer
	movl	spec+s.l,r4		; char count
	beql	exit
loop:	movzbl	(r3)+,r2		; get a character
	movb	r0,table[r2]		; make syntax table entry
	sobgtr	r4,loop
exit:
	.endm


.macro	pop	args
;
;	pop descriptors off sysstk
;
	.irp	arg,<args>
	.if nb,arg
	movq	-(r11),arg
	.endc
	.endr
	.endm


.macro	proc   	null1,null2
	.endm


.macro	pstack	descr1
	subl3	#descr*2,r11,descr1+d.a
	clrl	descr1+d.vv
	.endm


.macro	push	args
;
;	push descrs onto sysstk
;
	.irp	arg,<args>
	.if nb,arg
	movq	arg,(r11)+
	.endc
	.endr
	.endm


.macro	putac  	descr1,n,descr2
	movl	descr1+d.a,r2
	movl	descr2+d.a,n(r2)
	.endm


.macro	putd   	descr1,descr2,descr3
;
;	addr of(d1.v + d2.v) = d3
;
	addl3	descr1+d.a,descr2+d.a,r1
	movq	descr3,(r1)
	.endm


.macro	putdc  	descr1,n,descr2
;
;	addr(d1.v + const) = d2
;
	movl	descr1+d.a,r1
	movq	descr2,n(r1)
	.endm


.macro	putlg  	spec,descr
	movl	descr+d.a,spec+s.l
	.endm


.macro	putspc 	descr,n,spec
	movl	descr+d.a,r1
	movq	spec,n(r1)
	movq	spec+s.o,n+s.o(r1)
	.endm


.macro	putvc  	descr1,n,descr2
	extzv	#d.v,#d.vl,descr2,r3	; gET v FIELD INTO R3
	movl	descr1+d.a,r1
	insv	r3,#d.v,#d.vl,n(r1)	; pUT V FIELD FROM R3 INTO DESCR
	.endm


.macro	rcall	descr,proc,prmlst,rtnlst,?rtn,?s
;
;	call proc pr passing descriptors prmlst on sysstk
;	branching to retlst on return condition in r1
;
; stack:	  .
;		r10
;		  0
;		a(return)
;		  0
;		pn
;		pn-1
;		  .
;		p2
;		p1
;
;
	movl	r11,r0
	movl	r10,(r11)+
	clrl	(r11)+
	moval	rtn,(r11)+
	clrl	(r11)+
	rchlp	prmlst
	movl	r0,r10
	jmp	proc		; call the routine
	;************************
rtn:	tstl	r3		; is there a return parameter?
	beql	s
	.iif nb,descr,	movq	r0,descr
s:	mcase	rtnlst
	.endm

.macro	rchlp	p1,p2,p3,p4,p5,p6,p7,p8,p9
	.narg	nargs
	.if ne nargs
	addl2	#nargs*descr,r11
	movl	r11,r3
	xxxx=0
	.irp	prm,<p1,p2,p3,p4,p5,p6,p7,p8,p9>
	.iif nb,prm,	movq	prm,-(r3)
	.iif b,prm,	movq	#0,-(r3)
	xxxx=xxxx+1
	.iif le nargs-xxxx,.mexit
	.endr
	.endc
	.endm


.macro	rcomp	descr1,descr2,gt,eq,lt
	cmpf	descr1+d.a,descr2+d.a
	gel	gt,eq,lt
	.endm



.macro	realst 	spec,descr,?q,?b,?c,?d,?e,?f
	cvtfd	descr+d.a,f
	pushl	#4		; digits in fraction
	pushal	q
	pushal	f
	calls	#3,g^for$cvt_d_tf	; call convert routine
	brb	b
q:	.word	10	; length
	.byte	14
	.byte	1
	.long	c	; address
c:	.ascii	/+999999999/
f:	.quad	0			; d floating number
b:	clrl	spec+d.vv
	clrl	spec+s.o
	moval	c,r1			; r1->blanks
e:	cmpb	(r1),#^a/ /		; is it a blank?
	bneq	d			; brifnot
	incl	r1
	brb	e
d:	movl	r1,spec+d.a
	subl3	r1,#c+10,spec+s.l	; length of string
	.endm


.macro	remsp  	spec1,spec2,spec3
	movq	spec2,spec1
	addl3	spec2+s.o,spec3+s.l,spec1+s.o
	subl3	spec3+s.l,spec2+s.l,spec1+s.l
	.endm


.macro	resetf 	descr,flag
	bicb2	#flag,descr+d.f
	.endm


.macro	rewind 	descr
	pushl	descr+d.a
	calls	#1,for$rewind
	.endm


.macro	rlint	descr1,descr2,fail,succ
	cvtfl	descr2+d.a,descr1+d.a
	clrb	descr1+d.f
	movl	#i,r1
	insv	r1,#d.v,#d.vl,descr1
	.iif nb,succ,	jmp	succ
	.endm


.macro	rplace 	spec1,spec2,spec3,?loop,?not,?bye
	addl3	spec1+d.a,spec1+s.o,r2
	addl3	spec2+d.a,spec2+s.o,r3
	addl3	spec3+d.a,spec3+s.o,r4
	clrl	r5			; char counter
loop:	cmpl	r5,spec1+s.l
	bgeq	bye
	movzbl	(r2)[r5],r6		; get next character
	locc	r6,spec2+s.l,(r3)	; find char in replace string
	beql	not
	subl2	r3,r1			; r1=disp to character
	addl2	r4,r1
	movb	(r1),(r2)[r5]		; do the replace
not:	incl	r5
	brb	loop
bye:
	.endm


.macro	rrturn 	descr1,n
;
;	return descriptor x, cond to take on return = c
; stack:
;		.
;		.
;	      -----------------------------
;	r10-> old stack pointer (old r10)
;		zero
;	      -----------------------------
;	      addr(return location)
;		zero
;	      -----------------------------
;
;  r0,r1=descriptor to return
;  r2=condition code
;  r3=descriptor present flag
;
	.if nb,descr1
	movq	descr1,r0
	movl	#1,r3			; flag descriptor present
	.iff
	clrl	r3			; flag no descriptor present
	.endc
	movl	#n,r2			; condition code
	movl	r10,r11
	movl	d.a(r11),r10
	jmp	@descr(r11)
	.endm


.macro	rsetfi 	descr,flag
	movl	descr+d.a,r1
	bicb2	#flag,d.f(r1)
	.endm


.macro	sbreal 	descr1,descr2,descr3,fail,succ
	subf3	descr3+d.a,descr2+d.a,r1
	movf	r1,descr1+d.a
	.iif dif,descr2,descr1,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	selbra 	descr,locs
	movl	descr+d.a,r2
	mcase	locs
	.endm


.macro	setac  	descr,n
	movl	#n,descr+d.a
	.endm


.macro	setav  	descr1,descr2
	extzv	#d.v,#d.vl,descr2,r3	; gET v FIELD INTO R3
	movl	r3,descr1+d.a
	clrl	descr1+d.vv
	.endm


.macro	setf	descr,flag
	bisb2	#flag,descr+d.f
	.endm


.macro	setfi	descr,flag
	movl	descr+d.a,r1
	bisb2	#flag,d.f(r1)
	.endm


.macro	setlc  	spec,n
	movl	#n,spec+s.l
	.endm


.macro	setsiz 	descr1,descr2
	movl	descr1+d.a,r1
	movl	descr2+d.a,r2
	insv	r2,#d.v,#d.vl,(r1)
	.endm


.macro	setsp  	spec1,spec2
	movq	spec2,spec1
	movq	spec2+s.o,spec1+s.o
	.endm


.macro	setva	descr1,descr2
	insv	descr2+d.a,#d.v,#d.vl,descr1
	.endm


.macro	setvc	descr,n
	insv	#n,#d.v,#d.vl,descr
	.endm


.macro	shortn 	spec,n
	subl2	#n,spec+s.l
	.endm


.macro	spcint	descr,spec,fail,succ,?strdsc,?end,?err,?rtnval
	addl3	spec+d.a,spec+s.o,strdsc+4
	movw	spec+s.l,strdsc
	pushal	rtnval
	pushal	strdsc
	calls	#2,g^ots$cvt_ti_l
	cmpl	#ss$_normal,r0
	bneq	err
	movl	rtnval,descr+d.a
	clrb	descr+d.f
	movzbl	#i,r1
	insv	r1,#d.v,#d.vl,descr
	.iif nb,succ,	jmp	succ
	.iif b,succ,	brb	end
err:	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
strdsc:	.word	.-.	; length of string
	.byte	14
	.byte	1
	.long	.-.	; string address
rtnval:	.long	.-.
end:
	.endm


.macro	spec	a=0,f=0,v=0,o=0,l=0
	descr	a,f,v
	.long	o
	.long	l
	.endm


.macro	spop	args
;
;	pop specifiers off sysstk
;
	.irp	arg,<args>
	.iif nb,arg,	movq	-(r11),arg+s.o
	.iif nb,arg,	movq	-(r11),arg
	.endr
	.endm


.macro	spreal 	descr,spec,fail,succ,?err,?rtnval,?end,?strdsc
	addl3	spec+d.a,spec+s.o,strdsc+4
	movw	spec+s.l,strdsc
	pushal	rtnval
	pushal	strdsc
	calls	#2,g^ots$cvt_t_d
	cmpl	#ss$_normal,r0
	bneq	err
	cvtdf	rtnval,descr+d.a
	clrb	descr+d.f
	movzbl	#r,r1
	insv	r1,#d.v,#d.vl,descr
	.iif nb,succ,	jmp	succ
	.iif b,succ,	brb	end
err:	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
strdsc:	.word	.-.	; length of string
	.byte	14
	.byte	1
	.long	.-.	; string address
rtnval:	.quad	0
end:
	.endm


.macro	spush	args
;
;	push specifiers off sysstk
;
	.irp	arg,<args>
	.iif nb,arg,	movq	arg,(r11)+
	.iif nb,arg,	movq	arg+s.o,(r11)+
	.endr
	.endm


.macro	stprnt 	descr1,descr2,spec,?a,?b,?c,?d,?e
	addl3	spec+d.a,spec+s.o,quqdesc+4	; build the vax descr
	movw	spec+s.l,r1
	cmpw	r1,#132
	bleq	c
	movw	#132,r1
c:	movw	r1,quqdesc
;---------------------------			; 27-jan-82
	movl	descr2,r2
	cmpl	descr(r2),#10			; is format no. <= 10
	bleq	d
	movw	r1,f1a132+2
	pushab	f1a132				; format
	brb	e

d:	movw	r1,f1x1a132+4
	pushab	f1x1a132			; format
;---------------------------
e:	pushl	descr(r2)			; unit number
	calls	#2,qstprnt
	.endm


.macro	stread 	spec,descr,eof,error,succ,?a,?b,?c
	movw	spec+s.l,r0
	pushl	r0
	addl3	spec+d.a,spec+s.o,r1
	pushl	r1
c:	pushl	descr+d.a	; unit no.
	calls	#3,qstread
	.if nb,error
	tstl	r0
	beql	a
	jmp	error
a:
	.endc
	.if nb,eof
	tstl	r1
	beql	b
	jmp	eof
b:
	.endc
	.iif nb,succ,	jmp	succ
	.endm


.macro	stream 	spec1,spec2,table,error,runout,success,?z,?x
;
;	do a "trt" on string q2
;	q1=output descr, t=syntax table, e=error addr,
;	goto r if end-of-string, s if value found
	pushal	spec1
	pushal	spec2
	pushal	table
	calls	#2,stream
	movl	z[r0],r1
	jmp	(r1)
z:	.iif nb,success,	.long	success
	.iif b,success,		.long	x
	.iif nb,error,		.long	error
	.iif b,error,		.long	x
	.iif nb,runout,		.long	runout
	.iif b,runout,		.long	x
x:
	.endm


.macro	string	s
	.nchr	z,<s>
	.save_psect
	.psect	string,shr,nowrt
$$$=.
	.ascii	"s"
	.restore_psect
	spec	$$$,0,0,0,z
	.endm


.macro	subsp	spec1,spec2,spec3,fail,succ,?a
	cmpl	spec3+s.l,spec2+s.l
	.if nb,fail
	bgeq	a
	jmp	fail
a:
	.endc
	movq	spec3,spec1
	movl	spec3+s.o,spec1+s.o
	movl	spec2+s.l,spec1+s.l
	.iif nb,succ,	jmp	succ
	.endm


.macro	subtrt 	descr1,descr2,descr3,fail,succ,?a
	subl3	descr3+d.a,descr2+d.a,r1
	.if nb fail
	bvc	a
	jmp	fail
a:	nop
	.endc
	movl	r1,descr1+d.a
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	sum    	descr1,descr2,descr3,fail,succ,?a
	addl3	descr3+d.a,descr2+d.a,r1
	.if nb fail
	bvc	a
	jmp	fail
a:	nop
	.endc
	movl	r1,descr1+d.a
	.iif dif,descr1,descr2,	movl	descr2+d.vv,descr1+d.vv
	.iif nb,succ,	jmp	succ
	.endm


.macro	testf	descr,flag,fail,succ,?there,?end
	bitb	#flag,descr+d.f
	bneq	there
	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
there:	.iif nb,succ,	jmp	succ
end:
	.endm


.macro	testfi	descr,flag,fail,succ,?there,?end
	movl	descr+d.a,r1
	bitb	#flag,d.f(r1)
	bneq	there
	.iif nb,fail,	jmp	fail
	.iif b,fail,	brb	end
there:	.iif nb,succ,	jmp	succ
end:
	.endm


.macro	top    	descr1,descr2,descr3,?a,?loop
	movl	descr3+d.a,r3
loop:	bitb	#ttl,d.f(r3)
	bneq	a			; brif bit set
	subl3	#descr,r3,r3
	cmpl	r3,#obstrt+descr*obsiz	; end of stack?
	blss	loop			; brifnot
	halt
a:	movl	r3,descr1+d.a
	movl	descr3+d.vv,descr1+d.vv
	subl3	r3,descr3+d.a,descr2+d.a
	clrl	descr2+d.vv
	.endm


.macro	trimsp 	spec1,spec2,?loop,?exit
	addl3	spec2+d.a,spec2+s.o,r2
	addl2	spec2+s.l,r2	; r2->beyond last char
	decl	r2		; r2->last character
	movl	spec2+s.l,r1	; char count
loop:	tstl	r1
	beql	exit		; null string
	cmpb	(r2),#^a/ /	; is it a space?
	bneq	exit
	decl	r1
	decl	r2
	brb	loop
exit:	movq	spec2,spec1
	movl	spec2+s.o,spec1+s.o
	movl	r1,spec1+s.l
	.endm


.macro	unload	spec
		; disabled: external functions
	;$delva_s inadr=range
	;$dassgn_s chan=fab+fab$l_stv
	.endm


.macro	varid	descr,spec
;
;	hash macro
; this macro was taken directly from "the macro implementation of
; snobol4" by r.e. grislold; page 191
;
;  r1->descriptor
;  r2->string
;  r3= length
;  r4=
;  r5=
;  r6= i1
;  r7= i2
;  r8= product = h1
;  r9= product = h2
;
	moval	spec,r1
	addl3	d.a(r1),s.o(r1),r2	; r2->string
	movl	s.l(r1),r3		; r3=length
	cmpw	r3,#4			; 1<=n<=4 ?
	blssu	4$			; brifso
	cmpw	r3,#8			; 5<=n<=8 ?
	blssu	8$			; brifso
					; n>8
	; (scan for 1st non-blank ?)
	movl	(r2),r6			; r6=i1
	movl	4(r2),r7		; r7=i2
	brb	10$

8$:	movl	(r2),r6			; r6=i1
	addl2	r3,r2
	movl	-4(r2),r7		; r7=i2
	brb	10$

4$:	ashl	#3,r3,r7
	extzv	#0,r7,(r2),r6		; r6=i1
	movl	r6,r7			; r7=i2

10$:	rotl	#-19,r6,r6		; (1) i1 is rotated right 19 bits
	emul	r6,r7,#0,r4		; (2) i1 & i2 are multiplied
	movl	r4,r6			;
	ashq	#11,r5,r5		; (3) product shifted 11 bits
					; (4) r6=order number
	ashl	#24,r3,r3		; (5) length shifted left 24 bits
	addl2	r3,r5			;     and added to low order 32 bits
	bicl2	#^x80000000,r5
	ashl	#<-24+3>,r5,r5		; (6,7) shifted right 24 bits and
					;     multiplied by dwdth
	bicl2	#^xfffff807,r5		; make valid bucket number
	movl	r5,descr+d.a
	insv	r6,#d.v,#d.vl,descr	
	.endm


.macro	vcmpic 	descr1,n,descr2,gtb,eqb,ltb
	movl	descr1+d.a,r1
	extzv	#d.v,#d.vl,descr2,r3
	cmpzv	#d.v,#d.vl,n(r1),r3
	gel	gtb,eqb,ltb
	.endm


.macro	veql	descr1,descr2,neb,eqb
	extzv	#d.v,#d.vl,descr2,r3
	cmpzv	#d.v,#d.vl,descr1,r3
	nebr	neb,eqb
	.endm


.macro	veqlc	descr1,n,neb,eqb
	cmpzv	#d.v,#d.vl,descr1,#n
	nebr	neb,eqb
	.endm


.macro	zerblk	descr1,descr2,?loop,?out
	movl	descr1+d.a,r1
	movl	descr2+d.a,r2
	beql	out
	addl2	r1,r2
loop:	clrq	(r1)
	acbl	r2,#descr,r1,loop
out:
	.endm