.set	version, 73

/* UNIX version */
/* (begin long comment)

Various assembler requirements: here for reference:

RADIX CONTROL:
	leading 0 ==> octal
	no leading 0 ==> decimal
	leading 0X (0x) ==> hex
	floats, if I need them...

TEXT:
	'C ==> ascii value of C
	"string" ==> counted string (try this...)
	
LABELS:
	Lfoo labels are discarded
	n: (0 <= n <= 9) ==> local label, nb(ackwards) nf(orward) references

OPERATORS:
	+ - * /  obvious
	% modulo
	(& and) (| or) (^ xor) (> right-shift) (< left-shift) (! or-not)

OTHER:
	.ALIGN n ==> align to n-zero boundary
	.SPACE n ==> N bytes of zeros are assembled
	.BYTE (.WORD .LONG .QUAD) expr, expr, expr, expr, ....
	.ASCII (.ASCIZ) string, string, string, ...

	.SET symbol, value ==> enter SYMBOL into symbol table
	
!!!	use $ instead of #	!!!
!!!	use * instead of @	!!!

(end comment) */


/* Begin long comment about MDL

Register allocation:

	TP (r13)	;MDL stack
	FR (r12)	;MDL frame
	MS (r11)	;Current MSUBR pointer

	r0		;Type in type/value pair
	r1		;Value

Memory layout: (addresses are in hex)

P0:		=========================
0000 0000	I	dispatch	I
		I	 table		I
		=========================
0000 0200	I	  MIMI		I
		I	  code		I
		=========================
000? ????	I      Pure space	I
		=========================
000? ????	I      FBIN space	I
		=========================
000? ????	I	MDL stack	I
		I	   ||		I
		I	   ||		I
		I	  \||/		I
		I	   \/		I
3FFF FFFF	.........................

P1:		.........................
4000 0000	I			I
		I	   /\		I
		I	  /||\		I
		I	   ||		I
		I	   ||		I
7FFF FAFF:	I	GC space	I
		=========================
		I	(1 Kword)	I
7FFF FBFF:	I	SP stack	I
		=========================
		I	 system		I
		I	variables	I
7FFF FFFF	I	(1 Kword)	I
		=========================

(end long MDL comment)	*/

/* definitions of system calls */

	.set	_exit, 1
	.set	_fork, 2
	.set	_read, 3
	.set	_write, 4
	.set	_open, 5
	.set	_close, 6
/*	.set	_wait, 7	*/
	.set	_creat, 8
	.set	_link, 9
	.set	_unlink, 10
	.set	_exec, 11
	.set	_chdir, 12
/*	.set	_time, 13	*/
	.set	_mknod, 14
	.set	_chmod, 15
	.set	_chown, 16
	.set	_break, 17	/* seems to still exist */
/*	.set	_stat, 18	*/
	.set	_lseek, 19
	.set	_getpid, 20
	.set	_mount, 21
	.set	_umount, 22
/*	.set	_setuid, 23	*/
	.set	_getuid, 24
/*	.set	_stime, 25	*/
	.set	_ptrace, 26
/*	.set	_alarm, 27	*/
/*	.set	_fstat, 28	*/
/*	.set	_pause, 29	*/
/*	.set	_utime, 30	*/
/*	.set	_stty, 31	*/
/*	.set	_gtty, 32	*/
	.set	_access, 33
/*	.set	_nice, 34	*/
/*	.set	_ftime, 35	*/
	.set	_sync, 36
	.set	_kill, 37
	.set	_stat, 38
/*	.set	_setpgrp, 39	*/
	.set	_lstat, 40
	.set	_dup, 41
	.set	_pipe, 42
/*	.set	_times, 43	*/
	.set	_profil, 44
/*	.set	_setgid, 46	*/
	.set	_getgid, 47
/*	.set	_signal, 48	*/
	.set	_acct, 51
/*	.set	_phys, 52	*/
/*	.set	_lock, 53	*/
	.set	_ioctl, 54
	.set	_reboot, 55
/*	.set	_mpx, 56	*/
	.set	_symlink, 57
	.set	_readlink, 58
	.set	_execve, 59
	.set	_umask, 60
	.set	_chroot, 61
	.set	_fstat, 62
	.set	_getpagesize, 64
	.set	_mremap, 65
/*	.set	_vfork, 66	*/
/*	.set	_vread, 67	*/
/*	.set	_vwrite, 68	*/
	.set	_sbrk, 69
	.set	_sstk, 70
	.set	_mmap, 71
/*	.set	_vadvise, 72	*/
	.set	_vhangup, 76
/*	.set	_vlimit, 77	*/
	.set	_mincore, 78
	.set	_getgroups, 79
	.set	_setgroups, 80
	.set	_getpgrp, 81
	.set	_setpgrp, 82
	.set	_setitimer, 83
	.set	_wait, 84
	.set	_vswapon, 85
	.set	_getitimer, 86
	.set	_gethostname, 87
	.set	_sethostname, 88
	.set	_getdtablesize, 89
	.set	_dup2, 90
	.set	_getdopt, 91
	.set	_fcntl, 92
	.set	_select, 93
	.set	_setdopt, 94
	.set	_fsync, 95
	.set	_setpriority, 96
	.set	_socket, 97
	.set	_connect, 98
	.set	_accept, 99
	.set	_getpriority, 100
	.set	_send, 101
	.set	_recv, 102
	.set	_bind, 104
	.set	_setsockopt, 105
	.set	_listen, 106
	.set	_vtimes, 107
	.set	_sigvec, 108
	.set	_sigblock, 109
	.set	_sigsetmask, 110
	.set	_sigpause, 111
	.set	_sigstack, 112
	.set	_recvmsg, 113
	.set	_sendmsg, 114
	.set	_gettimeofday, 116
	.set	_getrusage, 117
	.set	_getsockopt, 118
	.set	_readv, 120
	.set	_writev, 121
	.set	_settimeofday, 122
	.set	_fchown, 123
	.set	_fchmod, 124
	.set	_recvfrom, 125
	.set	_setreuid, 126
	.set	_setregid, 127
	.set	_rename, 128
	.set	_truncate, 129
	.set	_ftruncate, 130
	.set	_flock, 131
	.set	_sendto, 133
	.set	_shutdown, 134
	.set	_socketpair, 135
	.set	_mkdir, 136
	.set	_rmdir, 137
	.set	_utimes, 138
	.set	_revoke, 140
	.set	_getpeername, 141
	.set	_gethostid, 142
	.set	_sethostid, 143
	.set	_getrlimit, 144
	.set	_setrlimit, 145
	.set	_killpg, 146
	.set	_setquota, 148
	.set	_quota, 149
	.set	_getsockname, 150

/* Random definitions */

	.set upages, 12
	.set ubytes, upages*512
	.set topwds, 5
	.set sysbot, 0x7FFFFFFF-ubytes-topwds*4+1
	.set intflg, 0x7FFFFFFF-ubytes-3
	.set stkbot, 0x7FFFFFFF-ubytes-7
	.set stkmax, 0x7FFFFFFF-ubytes-11
	.set bindid, 0x7FFFFFFF-ubytes-15
	.set spsto, 0x7FFFFFFF-ubytes-19
	.set L_SET, 0
	.set O_RDONLY, 0
	.set O_WRONLY, 1
	.set O_RDWR, 2
	.set O_NDELAY, 4
	.set O_APPEND, 10
	.set O_CREAT, 01000
	.set O_TRUNC, 02000
	.set O_EXCL, 04000
	.set _chmk, 0xBC
	.set EINTR, 4
	.set ENOSPC, 28
	.set sig_int, 2
	.set sig_quit, 3
	.set sig_ill, 4
	.set sig_fpe, 8
	.set sig_bus, 10
	.set sig_segv, 11
	.set sig_sys, 12
	.set sig_pipe, 13
	.set sig_alrm, 14
	.set sig_urg, 16
	.set sig_tstp, 18
	.set sig_cont, 19
	.set sig_chld, 20
	.set sig_ttou, 22
	.set sig_io, 23
	.set sig_xcpu, 24
	.set sig_xfsz, 25
	.set tiocsetn, 0x8006740a
	.set tioclset, 0x8004747d
	.set tiocsetc, 0x80067411
	.set tiocsltc, 0x80067475
	.set wds_page, 256		/* words per page */
	.set byts_page, wds_page*4	/* bytes per page */
	.set byts_page_sh, -10
	.set gcsize, 250000		/* words of gc initially */
	.set gcsizb, gcsize*4		/* bytes of gc space */
	.set gcsizp, gcsize/wds_page	/* pages of gc space */
	.set gcfoff, 12			/* offset into zone to point to gc */
	.set gcaoff, 44			/* list of areas in zone */
	.set abot, 0
	.set amin, 4
	.set amax, 8			/* offsets into area */
	.set tp_sizew, 100000		/* tp stack size (words) */
	.set tp_size, tp_sizew*4
	.set tp_buf, 6000		/* buffer above tp stack */
	.set pur_init, 52000		/* eventually enough to hold fbins */
	.set zlnt, 5			/* elements in a zone vector */
	.set rlimit_stack, 3		/* parameter to set max stack area size
					    which is gc space for us */ 
	.set rlimit_data, 2
	.set gcstart, 0x7FFFFAFF	/* start (top) of GC space */
	.set spstart, 0x7FFFFBFF	/* start (top) of system stack */
	.set hsize, 237			/* atom hash table size */
	.set lhsize, hsize*2+2		/* longwords needed for htable */

	.set minf.len, 10		/* length of minf vector */
	.set jmpa, 0x9f			/* start of JMP abs instruction */


/* Type code definitions */

	.set dope, 040		/* Dope bit for stack things */
	.set dope_bit, 02000000
	.set mark_bit, 0x8000

/* bit definitions sometimes usefull */
	.set bit0,  000000000001
	.set bit1,  000000000002
	.set bit2,  000000000004
	.set bit3,  000000000010
	.set bit4,  000000000020
	.set bit5,  000000000040
	.set bit6,  000000000100
	.set bit7,  000000000200
	.set bit8,  000000000400
	.set bit9,  000000001000
	.set bit10, 000000002000
	.set bit11, 000000004000
	.set bit12, 000000010000

	.set bit29, 004000000000
	.set bit30, 010000000000
	.set bit31, 020000000000

/* Primtypes */

	.set pt.fix,0
	.set pt.list,1
	.set pt.rec,2
	.set pt.bytes,4
	.set pt.str,5
	.set pt.uvec,6
	.set pt.vec,7
	.set pt.bits,7

/* types - coded so that rightmost 3 bits are primtype */


	.set	t.any, 0	/* not REALLY a type, but.. */

	.set	shft,0100	/* used to shift type code left */

	.set	t.unb, pt.fix+shft*0
	.set	t.fix, pt.fix+shft*1
	.set	t.char, pt.fix+shft*2
	.set	t.float, pt.fix+shft*3

	.set	t.list, pt.list+shft*4
	.set	t.false, pt.list+shft*5
	.set	t.decl, pt.list+shft*6

	.set	t.str, pt.str+shft*7
	.set	t.mcode, pt.uvec+shft*8
	.set	t.vec, pt.vec+shft*9
	.set	t.msubr, pt.vec+shft*10
	.set	t.tat, pt.vec+shft*34		/* out of order */

	.set	t.frame, pt.rec+shft*11
	.set	t.bind, pt.rec+shft*12
	.set	t.atom, pt.rec+shft*13
	.set	t.obl, pt.rec+shft*14
	.set	t.gbind, pt.rec+shft*15
	.set	t.qfram, pt.rec+shft*33		/* out of order */

	.set	t.form, pt.list+shft*16
	.set	t.typc, pt.fix+shft*17
	.set	t.term, pt.fix+shft*18
	.set	t.segm, pt.list+shft*19
	.set	t.defer, pt.list+shft*20
	.set	t.func, pt.list+shft*21
	.set	t.macro, pt.list+shft*22
	.set	t.chan, pt.vec+shft*23
	.set	t.entry, pt.vec+shft*24
	.set	t.adecls, pt.vec+shft*25
	.set	t.offs, pt.vec+shft*26
	.set	t.lval, pt.rec+shft*27
	.set	t.gval, pt.rec+shft*28
	.set	t.link, pt.rec+shft*29
	.set	t.tuple, pt.vec+shft*30
	.set	t.uvec, pt.uvec+shft*31
	.set	t.imsub, pt.vec+shft*32
	.set	t.sdtab, pt.vec+shft*35
	.set	t.diskc, pt.vec+shft*36
	.set	t.mudch, pt.vec+shft*37
	.set	t.word, pt.fix+shft*38
	.set	t.pcode, pt.uvec+shft*39
	.set	t.zone, pt.vec+shft*40
	.set	t.gcpar, pt.uvec+shft*41
	.set	t.area, pt.uvec+shft*42
	.set	t.sframe, pt.rec+shft*43
	.set	t.bytes, pt.bytes+shft*44
	.set	t.typw, pt.fix+shft*45
	.set	t.qsfra, pt.rec+shft*46
	.set	t.bits, pt.fix+shft*47
	.set	t.kentry, pt.vec+shft*48
	.set	t.fretyp, 49		/* first type for used-defined */

/* Internal structures */

  /* object:	(may be added to xx.obj to get real offset) */
	.set	o.typ, 0
	.set	o.cnt, 2
	.set	o.val, 4

	.set	ot, 0	/* shorthand alternates for object offsets */
	.set	oc, 2
	.set	ov, 4

  /* dope:	(usually added to xx.dope to find real offset) */
	.set	dp.typ, 0	/* type of this thing */
	.set	dp.len, 2	/* length */
	.set	dp.gc, 4	/* GC word */

  /* frame:	(stack offsets) */
	.set	fr.act, -4	/* relative PC stored for AGAIN */
	  .set	  fr.ffb, -1	
	  .set	  ffbit, 0200	/* 
		 note that the MSB of fr.act flags glued frames
		this is a kludge, but it works.  The bit is on
		iff the frame is NOT a glued frame. */
	.set	fr.tp, -6	/* TP to restore on AGAIN	(2 bytes) */
	.set	fr.sp, -8	/* SP pointer for frame		(2 bytes) */
	.set	fr.fra, -12	/* previous frame 		(4 bytes) */
	.set	fr.id, -14	/* unique frame ID 		(2 bytes) */
	.set	fr.arg, -16	/* number of args		(2 bytes) */
	.set	fr.pc, -20	/* return PC			(4 bytes) */
	.set	fr.msa, -24	/* current msubr		(4 bytes) */
	.set	fr.head, -28	/* header word			(4 bytes) */

	.set	fr.len, 14	/* length of frame in 16-bit words */

  /* glued frame: */

	.set	gfr.pfr, -4	/* previous frame (check it...) */
/*  defined in frame...	.set	fr.ffb, -1	*/
	.set	gfr.fra, -8	/* previous not-glued  frame (check...) */
	.set	gfr.pc, -12	/* return PC */
	.set	gfr.typ, -14	/* type		(2 bytes)	*/

	.set	gfr.len, 7	/* length of glued frame in 16-bit words */


  /* cell: */
	.set	c.ptr, 0	/* pointer to rest */
	.set	c.obj, 4	/* cell object */

  /* vector, uvector, string:
		these are arrays of [objects/ fixes/ bytes]
		followed by the dope word	*/

  /* atom: */
	.set	a.gbind, 0	/* global binding	(4 bytes) */
	.set	a.lbind, 4	/* local binding	(4 bytes) */
	.set	a.name, 8	/* name			(8 bytes) */
	.set	a.obl, 16	/* oblist		(4 bytes) */
	.set	a.dope, 20	/* dope words		(n bytes) */
	
	.set	a.len, 5	/* length in words */

  /* gbind: */
	.set	gb.obj, 0	/* object		(8 bytes) */
	.set	gb.atom, 8	/* atom			(4 bytes) */
	.set	gb.decl, 12	/* decl			(8 bytes) */
	.set	gb.dope, 20	/* dope words		(n bytes) */

  /* lbind: */
	.set	lb.hdr, -4	/* header (only when on stack) (4 bytes) */

	.set	lb.obj, 0	/* object		(8 bytes) */
	.set	lb.atom, 8	/* atom			(4 bytes) */
	.set	lb.decl, 12	/* decl			(8 bytes) */
	.set	lb.prev, 20	/* previous binding	(4 bytes) */
	.set	lb.last, 24	/* last binding for this atom (4 bytes) */
	.set	lb.bid, 28	/* bind ID		(4 bytes) */
	.set	lb.dope, 32	/* dope words		(n bytes) */

	.set	lb.head, -4	/* hdr from pointer */
	.set	ln.bind, 8	/* length of local binding (longwords) */
	.set	ln.lbind, 16	/* length in words */
	.set	ln.bindb, 32

  /* msubr: */
	.set	ms.im, 0	/* imsubr atom */
	.set	ms.name, 8	/* name atom */
	.set	ms.decl, 16	/* decl */
	.set	ms.off, 24	/* offset into msubr code */

  /* imsubr: */
	.set	im.code, 0	/* pointer to code uvector */
	.set	im.atom, 4	/* atom */
	.set	im.free, 12	/* beginning of rest of junk */

/* Ascii characters */
	.set	chtab, 011
	.set	chlf, 012
	.set	chvt, 013
	.set	chff, 014
	.set	chcr, 015
	.set	chspc, 040

/* GC definitions	*/

	.set	gcpoff, 4

	.text
/* put in jump at address 0 */
txtstr:	.word	0		/* it seems that first word is skipped */
	jmp	booter
	.align	2		/* start dispatch table at 8 */

/* dispatch table - each entry is a longword - referenced by all code */
/* nop instructions used to align longwords */
	brw	iret
	nop
	brw	iframe
	nop
	brw	mcall
	nop
	brw	icons
	nop
	brw	incall
	nop
	brw	igets
	nop
	brw	isets
	nop
	brw	ifixbn
	nop
	brw	iunbind
	nop
	brw	record
	nop
	brw	bvecto
	nop
	brw	blist
	nop
	brw	ibind
	nop
	brw	ublock
	nop
	brw	iactiv
	nop
	brw	iagain
	nop
	brw	retry
	nop
	brw	irtuple
	nop
	brw	ituple
	nop
	brw	lckint
	nop
	brw	newtype
	nop
	brw	open
	nop
	brw	close
	nop
	brw	read
	nop
	brw	print
 	nop
	brw	isave
 	nop
	brw	irestor		/* brw	irestor	*/
 	nop
	brw	illdis		/* brw	random	*/
 	nop
	brw	comper
 	nop
	brw	birec
 	nop
	brw	nthu
 	nop
	brw	restu
 	nop
	brw	putu
 	nop
	brw	nthr
 	nop
	brw	putr
 	nop
	brw	backu
 	nop
	brw	topu
 	nop
	brw	illdis		/* ireset ?? */
 	nop
	brw	iatic
 	nop
	brw	iargs
 	nop
	brw	ciemp
 	nop
	brw	cinth
 	nop
	brw	cimon
 	nop
	brw	cirst
 	nop
	brw	cigas
 	nop
	brw	cigvl
 	nop
	brw	swnxt
 	nop
	brw	nexts
 	nop
	brw	relu		/* brw	relu	*/
 	nop
	brw	relr		/* brw	relr	*/
 	nop
	brw	rell		/* brw	rell	*/
 	nop
	brw	illdis		/* brw	conten	*/
 	nop
	brw	imarkr		/* brw	imarkr	*/
 	nop
	brw	imarkrq		/* brw	imarkrq	*/
 	nop
	brw	illdis		/* brw	syscalx	*/
 	nop
	brw	quit		/* brw	quit	*/
 	nop
	brw	tmptbl
 	nop
	brw	setzon		/* brw	setzon	*/
 	nop
	brw	legal
 	nop
	brw	unwcnt
 	nop
	brw	mpages
 	nop
	brw	illdis		/* brw	iputs	*/
 	nop
	brw	iacall
	nop
	brw	syscal
	nop
	brw	rntime
	nop
	brw	sframe
	nop
	brw	mretur
	nop
	brw	typew
	nop
	brw	typewc
	nop
	brw	savtty
	nop
	brw	dfatal
	nop
	brw	gettty
	nop
	brw	dopipe
	nop
	brw	ugverr
	nop
	brw	movstk
	nop
	brw	getstk
	nop
	brw	uublock
	nop
	brw	sblock
	nop
	brw	usblock
	nop
	brw	iassq
	nop
	brw	ilval
	nop
	brw	iset
	nop
	brw	bigstk

/* Utility routines for following... */

/* Unglue a frame, returns new frame pointer in r12 */

ungfrm:	tstb	fr.ffb(r12)	/* is it already real frame? */
	blss	1f		/* yes, return */
	 movl	fr.act(r12),r12	/* otherwise, chase pointer */
	 jbr	ungfrm		/* iterate */
1:	rsb			/* return to caller */

/* Print MDEPTH spaces on terminal */

prspac:	pushl	r2		/* save a temp */
	movl	mdepth,r2	/* get indentation count */
1:	movl	$spaces,r1	/* address of spaces */
	movl	$1,r3		/* just print one */
	clrl	r5		/* print to tty */
	bsbw	print
	sobgtr	r2,1b		/* loop for all spaces to print */
	movl	(sp)+,r2	/* restore register */
	rsb


/************************************************************************
*									*
*		.subtitle Stack Operations				*
*									*
*		frame, mcall, bind, legal, args, tuple, return		*
*		unbind, retry, activation, rtuple, again		*
*									*
*************************************************************************/

/* iset - set lval.  May call SET (via I$EICC) if needs to make
   top-level binding.  Takes value in r2, r3; atom in r0 */
iset:	movl	a.lbind(r0),r1
	 jeql	isetgr			/* no lbind pointer, need top-level */
	cmpl	lb.bid(r0),bindid	/* right bindid? */
	 jneq	isetgr1			/* no, try to find a good one */
isetdn:	movq	r2,lb.obj(r1)
	movq	r2,r0
	rsb
isetgr1:
	bsbw	iassq			/* get lbind pointer in r1 */
	tstl	r1
	 jneq	isetdn			/* go do it */
isetgr:	subl3	(sp),im.code+ov(r11),(sp)
	movl	ecall,r1
	 jeql	noeicc
	bsbw	iframe
	movl	$(a.len<17+t.atom),(r13)+
	movl	r0,(r13)+
	movq	r2,(r13)+
	movl	$2,r0
	bsbw	mcallz
	subl3	(sp),im.code+ov(r11),(sp)
	rsb

/* lval - takes atom in 0, returns value in 0 and 1.  Calls
EICC if fails, lets loser erret value from that. */
ilval:	movl	a.lbind(r0),r1
	 jeql	lvalls
	cmpl	lb.bid(r1),bindid
	 jneq	lvalgr
	tstl	lb.obj(r1)
	 jeql	lvalls
	movq	lb.obj(r1),r0
	rsb
lvalgr:	bsbw	iassq		/* try to get an lbind */
	tstl	r1
	 jeql	lvalls
	movq	lb.obj(r1),r0
	rsb
lvalls:	subl3	(sp),im.code+ov(r11),(sp)
	movl	ecall,r1
	 jeql	noeicc
	bsbw	iframe
	movl	$(a.len<17+t.atom),(r13)+
	movl	r0,(r13)+
	movl	$1,r0
	bsbw	mcallz
	subl3	(sp),im.code+ov(r11),(sp)
	rsb

/* assigned? - return 0 or lbind pointer in r1, given atom in r0.
   saves all registers except 0*/
iassq:	movl	a.lbind(r0),r1		/* get lbind pointer */
	 jeql	iassfl			/* are none, lose */
	cmpl	lb.bid(r1),bindid	/* bindid OK? */
	 jneq	iassgr			/* no, grovel obscenely */
	tstl	lb.obj(r1)		/* check type */
	 jneq	iasswn			/* not unbound, so win */
iassfl:	clrl	r1
iasswn:	rsb

/* come here if bindid doesn't match.  Have to search binding chain
   for right thing. */
iassgr:	pushl	r2
	clrl	r2		/* flag */
	movl	spsto,r1	/* get binding chain */
	 jeql	iassg1		/* empty */
1:	cmpl	r0,lb.atom(r1)	/* same atom? */
	 jeql	iassex		/* see if has lval in it */
	movl	lb.prev(r1),r1	/* previous binding */
	 jneq	1b
	tstl	r2
	 jneq	iassgfl
iassg1:	incl	r2
	movl	tbind,r1
	 jneq	1b
iassgfl: clrl	r1
2:	movl	(sp)+,r2
	rsb
iassex:	tstl	lb.obj(r1)	/* see if not an unbound */
	 jeql	iassgfl		/* lose */
	brb	2b		/* win */

/* ibind - push a binding
* call:
*	r1/ lbind
* return:
*	r1/ new binding
*	(binding pushed on stack)
*	(saves all registers)		*/

ibind:	movl	$(ln.lbind+2)<16+dope+t.bind,(r13)+ /* push bind header > */
	movl	r13,r1		/* save tp now */
	clrq	(r13)+
	clrq	(r13)+		/* push a bunch of 0's (4 long words)*/
	clrq	(r13)+
	clrq	(r13)+		/* 4 more word, sigh */
	movl	spsto,-12(r13)	/* store current binding */
	movl	r1,spsto	/* this is current binding now */
	rsb			/* return */

/* sframe - generate a segment frame (same as frame...) */

sframe:	movl	$fr.len<16+dope+t.sframe, (r13)+   /* push frame header */
	brb	1f

/* iframe - generate an empty frame
* call:
* 	(no arguments)
* return:
* 	<empty frame has been pushed on TP stack>	*/

iframe: movl	$fr.len<16+dope+t.frame, (r13)+	/* push frame header */
1:	clrq	(r13)+
	clrq	(r13)+		/* zero rest of frame */
	clrq	(r13)+		/* zero rest of frame */
	bisb2	$ffbit,fr.ffb(r13)	/* light full-frame bit */
	rsb

/* mcall - call an msubr
* call:
*	r0/ # args
*	r1/ MSUBR being called
*
* returns: (from msubr, eventually)
* 	r0/ type
*	r1/ value		*/

mcallz:	movl	(sp)+,r2	/* get absolute return PC */
	jmp	mcallx		/* and go for it */

mcall:	tstl	mtrace		/* waste a whole word */
	 beql	1f		/* don't want a trace, skip it */

	pushr	$bit0+bit1+bit3+bit5 /* save registers used for print */
	incl	mdepth		/* nest count for printing spaces */
	pushl	r1		/* save atom pointer */
	bsbw	prspac		/* print many spaces */
	movl	$gtrt,r1	/* print greter-than on call */
	movl	$1,r3		/* single character */
	clrl	r5		/* to tty */
	bsbw	print
	movl	(sp)+,r1	/* restore atom pointer */
	movzwl	10(r1),r3	/* get character count */
	movq	8(r1),r0	/* string pointer */
	clrl	r5		/* channel 0 */
	bsbw	print		/* print MSUBR name */
	movl	$crlf,r1
	movl	$2,r3		/* 2 characters */
	clrl	r5		/* to terminal */
	bsbw	print		/* print crlf */
	popr	$bit0+bit1+bit3+bit5 /* restore dem registers */

1:	subl3	(sp)+,im.code+ov(r11),r2	 /* get return PC from sp
						    and relativize it */
mcallx:	movl	a.gbind(r1),r3	/* get global binding of atom */
	 jneq	1f
gongs:	  jmp	calngs		/*  none, complain */

1:	cmpw	ot+gb.obj(r3),$t.msubr /* is it an msubr? */
	 jneq	gongs		/*  no, complain */
	movl	ov+gb.obj(r3),r4 /* get value (msubr) into r4 */
				/* drop through into ICRET */

icret:	movl	ov+ms.im(r4),r5	/* get imsubr atom from msubr */
	movl	a.gbind(r5),r10	/* its global binding */
	 jneq	1f
comgo:	  bsbw	comper		/*  none - compiler error */
1:	cmpw	ot+gb.obj(r10),$t.imsub /* is it an IMSUBR? */
	 jneq	comgo		/*  NO, compiler blew it */
	movl	ov+gb.obj(r10),r11 /* mvector to MS */
	movl	r12,r7		/* save frame in case it we change it */
icret1:
	bsbw	ungfrm		/* chase down real frame */

	movl	spsto,r3	/* check spsto */
	 beql	1f		/* if zero, dont relativize */
	subl2	r12,r3		/* relative to frame */
1:	movw	r3,fr.sp(r12)	/* save current SP */
	movl	r2,fr.pc(r12)	/* save return PC */
	ashl	$3,r0,r3	/* number of bytes needed for arguments */
				/* CHANGE TO NEW FRAME */
	subl3	r3,r13,r12	/* new fr ptr now in FR */
	movl	r4,fr.msa(r12)	/* store pointer to new MSUBR in NEW frame */
	movl	r7,fr.fra(r12)	/* pointer to previous frame */
	incl	framid		/* bump frame id */
	movw	framid,fr.id(r12) /* and store in new frame */
	movw	r0,fr.arg(r12)	/* store number of args */

	addl3	ms.off+ov(r4),im.code+ov(r11),r8	/* add offset */
	tstl	intflg		/* any interrupts */
	 jneq	1f		/* yes, handle them instead */
2:	jmp	(r8)		/* and jump to code... finally! */

1:	tstl	ingc		/* dont int if in gc */
	 jneq	2b
	movl	$t.fix,(r13)+
	movl	r0,(r13)+	/* save number of args */
	movl	$t.fix,(r13)+
	subl3	r8,im.code+ov(r11),(r13)+	/* save pc */
intlop:	ffs	$0,$32,intflg,r8
	 jeql	noincl		/* seems unlikely */
	pushr	$bit0+bit1
	locc	r8,intlen,intb1
	 jneq	4f
	popr	$bit0+bit1
	brw	noincl		/* muddle doesn't know about it */
4:	bsbw	iframe
	movl	$t.fix,(r13)+	/* call with correct args */
	movzbl	intb2(r0),(r13)+ /* pick up muddle interrupt number */
	popr	$bit0+bit1
	movl	icall,r1	/* get pointer to int routine */
	 jeql	losint		/* loser */
	
	ashl	r8,$1,r8
	bicl2	r8,intflg	/* clear intflg */
	movl	$1,r0
	bsbw	mcallz		/* call interrupt handler */
	tstl	intflg
	 jneq	intlop		/* more to come */
	subl3	-(r13),im.code+ov(r11),r8
	subl2	$4,r13
	movl	-(r13),r0
	subl2	$4,r13
	jmp	(r8)

noincl:	ashl	r8,$1,r8
	bicl2	r8,intflg
	 jneq	intlop
	subl3	-(r13),im.code+ov(r11),r8
	subl2	$4,r13
	movl	-(r13),r0
	subl2	$4,r13
	jmp	(r8)

losint:	movl	$intlos,r1
	movl	lintlos,r3
	clrl	r5
	bsbw	print
	brw	die

/* ifixbn - fix binding
* call:
* 
* return:
*	(must save ALL registers)	*/

ifixbn:	pushl	r0		/* save registers r0,r1 */
	pushl	r1
	movl	spsto,r0	/* current binding pointer to r0 */
1:	cmpl	r0,r12		/* compare to current frame */
	 blss	2f
	movl	lb.atom(r0),r1	/* get atom */
	movl	r0,a.lbind(r1)	/* rebind it */
	movl	lb.prev(r0),r0	/* and chain */
	brb	1b

2:	movl	(sp)+,r1		/* restore work registers */
	movl	(sp)+,r0
	rsb


/* ilegal - determine legality of object
* call:
*	r0/ count,,type
*	r1/ value
* return:
*	r0/ type (fix=true) (false=false)
*	(must save registers) */

legal:	cmpw	r0,$t.frame	/* frame? */
	 jeql	lglfrm		/*  yes, test it */
	cmpw	r0,$t.bind	/* binding? */
	 jeql	lglbnd		/*  ok, test that */
	pushr	$bit2+bit3
	bicl3	$0xFFFFFFF8,r0,r2
	caseb	r2,$0,$7
lgltab:	.word	lgltru-lgltab
	.word	lgltru-lgltab
	.word	lgltru-lgltab
	.word	lgltru-lgltab
	.word	lglstr-lgltab
	.word	lglstr-lgltab
	.word	lgluvc-lgltab
	.word	lgltup-lgltab
lgltru:	popr	$bit2+bit3
	movl	$t.fix,r0	/* all else is legal */
	rsb			/* so report that */

lglstr:	ashl	$-16,r0,r2	/* get length of string */
	addl2	r2,r1
	cmpl	r1,tpmax
	 jgtr	lgltru
	cmpl	r1,r13
	 jgtr	lgllos
	cmpl	r1,tpstart
	 jlss	lgltru
/* frob is on stack */
	bbc	$0,r1,1f
	incl	r1		/* point to halfword */
1:	tstw	(r1)
	 jneq	lgltst
	addl2	$2,r1		/* now we're at the dope word */
lgltst:	bitl	$dope,(r1)	/* is dope bit set? */
	 jeql	lgllos		/* no, lose */
	movzwl	2(r1),r2
	ashl	$2,r2,r2
	subl3	r2,r1,r2
	cmpl	(r1),4(r2)	/* compare the dope words */
	 jeql	lgltru
lgllos:	popr	$bit2+bit3
	movzwl	$t.false,r0
	clrl	r1
	rsb
lgluvc:	ashl	$-14,r0,r2	/* length in bytes */
	addl2	r2,r1		/* go to dope word */
	cmpl	r1,tpmax	/* check stack stuff */
	 jgtr	lgltru
	cmpl	r1,tpstart
	 jlss	lgltru
	cmpl	r1,r13
	 jgtr	lgllos
	brb	lgltst		/* hit common code */

lglfrm:	cmpl	r1,r13		/* check for inbounds */
	 jgtr	lglfls		/* return false */
	cmpl	r1,tpstart
	 jlss	lglfls
	cmpl	fr.head(r1),$fr.len<16+dope+t.frame   /* check frame header */
	 jeql	lglwin		/* lose return false */
	cmpl	fr.head(r1),$fr.len<16+dope+t.sframe
	 jneq	lglfls
lglwin:	movl	$t.fix,r0
	clrl	r1
	rsb

lglbnd:	cmpl	r1,tpmax
	 jgtr	lglwin		/* case of top-level lbind */
	cmpl	r1,r13		
	 jgtr	lglfls
	cmpl	r1,tpstart
	 jlss	lglfls
	cmpl	lb.head(r1),$(ln.lbind+2)<16+dope+t.bind	/* bind hdr? */
	 jeql	lglwin

lglfls:	movl	$t.false,r0
	clrl	r1
	rsb
lgltup:	cmpl	r1,tpmax
	 jgtr	lgltru
	cmpl	r1,r13
	 jgtr	lgllos
	cmpl	r1,tpstart
	 jlss	lgltru
/* Now know it points to valid stack area */
	cmpl	fr.head(r1),$fr.len<16+dope+t.frame	/* args of frame */
	 jeql	lgltru		/* this wins */
	cmpl	fr.head(r1),$fr.len<16+dope+t.sframe
	 jeql	lgltru
	bicl2	$0xFFFF,r0	/* kill type */
	ashl	$2-16,r0,r0	/* word index */
	cmpw	(r1)[r0],$t.tuple+dope
	 jeql	lgltru
	cmpw	(r1)[r0],$t.tuple
	 jeql	lgltru
	cmpw	(r1)[r0],$t.vec+dope
	 jeql	lgltru

/* here to see if rested args of frame */

	movl	r12,r2		/* point to current frame */

lgltu1:	tstb	fr.ffb(r2)	/* is this glued? */
	 blss	1f
	  movl	fr.act(r2),r2	/* loop back */
	   jbr	lgltu1

1:	cmpl	r1,r2		/* if tuple pntr is above frame,
				    this could be it */
	 jgtr	lgltu2
	movl	fr.fra(r2),r2	/* previous frame */
	jbr	lgltu1

lgltu2:	movaw	(r1)[r0],r1	/* rest given tuple to its end */
	movzwl	fr.arg(r2),r0	/* get # of args from frame */
	ashl	$3,r0,r0	/* change from objs to bytes */
	addl2	r0,r2		/* rest it to its end */
	cmpl	r2,r1		/* same end, therefore same legal tuple */
	 jeql	lgltru
	brw	lgllos

/* iargs - return argument tuple for a frame
* call:
*	r1/ frame
* return:
*	r0/ type
*	r1/ value
*	(may mung all registers)
*		(but doesn't) */

iargs:	movl	fr.arg-2(r1),r0 /* get count of args to LEFT HALF (kludge) */
	movw	$t.tuple,r0	/* new type word */
	rsb		/* r1 (frame pointer) points to tuple already */


/* igets - codes:	(1 args) (2 oblist) (3 bind) (4 ecall) (5 ncall)
*		(6 uwatm) (7 pagptr) (8 minf) (9 icall) (10 mapper)
*		(11 envir) (12 argv) (13 homstr)
* call:
* 	r1/ code (see above)
* return:
*	r0/ type
*	r1/ value
*	(saves all registers) */

igets:	caseb	r1,$1,$16	/* dispatch on type */
getab:	.word	getarg-getab
	.word	getobl-getab
	.word	getbnd-getab
	.word	gecall-getab
	.word	gncall-getab
	.word	guwatm-getab
	.word	gpgptr-getab
	.word	getmnf-getab
	.word	gicall-getab
	.word	gmappe-getab
	.word	genvir-getab
	.word	gargv-getab
	.word	ghomst-getab
	.word	grunin-getab
	.word	gtbind-getab
	.word	gtingc-getab
	bsbw	comper		/* should never reach this */

gtingc:	movzwl	$t.fix,r0
	movl	ingc,r1
	rsb

gtbind:	movq	tbindt,r0
	rsb

getarg:	movzwl	fr.arg(r12),r1	/* get number of args */
	movzbl	$t.fix,r0	/* and type */
	rsb

grunin:	movzwl	$t.fix,r0
	movl	runint,r1
	rsb

getobl:	movq	topobl,r0	/* type, value */
	rsb

getbnd:	movl	spsto,r1	/* current binding */
	movl	$(ln.lbind<16+t.bind),r0 /* > type word */
	rsb

gecall:	movl	ecall,r1	/* get current ecall */
	brb	retatm		/* and return atom */

gncall:	movl	ncall,r1	/* current ncall */
	brb	retatm

gicall:	movl	icall,r1	/* current icall */
	brb	retatm

guwatm:	movl	uwatm,r1	/* current uwatom */
retatm:	movl	$(a.len<17+t.atom),r0 /* > type word */
	rsb

gpgptr:	movq	pagptr,r0	/* current page pointer */
	rsb

getmnf:	movl	minf,r1		/* current minf */
	movl	$(minf.len<16+t.uvec),r0 /* > type */
	rsb

gmappe:	movl	mapper,r1	/* current mapper */
	brb	retatm

/* Can clobber r0,r1 */
genvir:	movl	envbeg,r0	/* Start of environment vec (set up by booter) */
	clrl	r1
	pushr	$bit2+bit3
3:	tstl	(r0)		/* Is it zero? */
	beql	6f		/* Yes, done */
	movl	(r0),r2		/* Get string pointer */
	clrl	r3		/* for length */
4:	tstb	(r2)		/* Found 0? */
	beql	5f		/* Yes, push a string pointer */
	incl	r2		/* No, point to next byte */
	aobleq	$1024,r3,4b	/* Aos count, try again */
5:	movw	$t.str,(r13)+	/* Push a type */
	movw	r3,(r13)+	/* Push a length */
	movl	(r0),(r13)+	/* Push a value */
	addl2	$4,r0
	aobleq	$1024,r1,3b	/* aos count, loop back */
6:	movw	$t.vec,r0
	bsbw	ublock		/* Make the vector */
	popr	$bit2+bit3
	rsb

/* return argument vector for process.  numarg and argbeg set up by
   startup code; returns false if no arguments */
gargv:	movl	numarg,r1
	 jleq	gargn		/* No arguments */
	pushr	$bit2+bit3
	movl	argbeg,r0
3:	clrl	r3
	movl	(r0),r2		/* point to a string */
1:	tstb	(r2)
	 beql	2f
	incl	r2
	aobleq	$1024,r3,1b
2:	movw	$t.str,(r13)+
	movw	r3,(r13)+
	movl	(r0),(r13)+	/* Push the string */
	addl2	$4,r0
	sobgtr	r1,3b
	movl	numarg,r1
	movw	$t.vec,r0
	bsbw	ublock
	popr	$bit2+bit3
	rsb
gargn:	movw	$t.false,r0
	clrl	r1
	rsb

ghomst:	movw	$homlen,r0
	ashl	$16,r0,r0
	movw	$t.str,r0
	moval	homstr,r1
	rsb

/* sets - codes as in gets above
* call:
*	r0/ type (not checked)
*	r1/ value to store
*	r3/ code
* returns:
*	r0/ type
*	r1/ value */

isets:	caseb	r3,$1,$16 	/* dispatch on type */
setab:	.word	seter-setab	/* args - error */
	.word	setobl-setab
	.word	setbnd-setab	/* binding - error */
	.word	secall-setab
	.word	sncall-setab
	.word	suwatm-setab
	.word	spgptr-setab
	.word	setmnf-setab
	.word	sicall-setab
	.word	smappe-setab
	.word	senvir-setab	/* a no-op */
	.word	senvir-setab	/* for argv--does nothing */
	.word	senvir-setab	/* for homstr--does nothing */
	.word	srunin-setab
	.word	stbind-setab
	.word	stingc-setab
seter:	bsbw	comper		/* should never reach this */

stingc:	movl	r1,ingc
	rsb

stbind:	movq	r0,tbindt
	rsb

srunin:	movl	$t.fix,(r13)+	/* push relative PC */
	subl3	(sp)+,im.code+ov(r11),(r13)+
	movl	$t.fix,(r13)+
	movl	r1,(r13)+
	bsbw	kerint		/* handle pending interrupts */
	movl	-(r13),runint	/* set up flag */
	subl2	$4,r13
	subl3	-(r13),im.code+ov(r11),-(sp)	/* restore PC */
	subl2	$4,r13
	rsb

setobl:	movq	r0,topobl
	rsb
setbnd:	movl	r1,spsto
	rsb
secall:	movl	r1,ecall
	rsb
sicall:	movl	r1,icall
	rsb
sncall:	movl	r1,ncall
	rsb
suwatm:	movl	r1,uwatm
	rsb
spgptr:	movq	r0,pagptr
	rsb
setmnf:	movl	r1,minf
	rsb
smappe:	movl	r1,mapper
senvir:	rsb

/* incall - internal call
* call:	bsb	ncall
* 	jmp	msubr
* return:
* 	frame set up, with
*	return address 3 bytes after bsb (after brw)
*	new frame has same MS, otherwise new	*/

incall:	subl3	(sp),im.code+ov(r11),r6		/* get return address 
						    and relativize */
	subl2	$3,r6		/* make frame return after jmp */
	bsbw	iframe		/* push an empty frame */
	movl	r12,r3		/* save old fr in case we change it */
	bsbw	ungfrm		/* chase last unglued frame */
	movl	spsto,r0	/* check for relativize needed */
	 beql	1f
	subl2	r12,r0
1:	movw	r0,fr.sp(r12)	/* save current SP */
	movl	r6,fr.pc(r12)	/* save return PC */
	movl	fr.msa(r12),r0	/* get msubr pointer for new guy */
				/* change to NEW frame */
	movl	r13,r12
	movl	r3,fr.fra(r12)	/* and previous frame	 */
	incl	framid		/* bump frame id */
	movw	framid,fr.id(r12) /* and store it in frame */
	movl	r0,fr.msa(r12)	/* for incall, msa is carried over */
	rsb


/* iret - MSUBR return code */


iret:	bsbw	frmfix		/* unravel the frame */
1:	subl3	r7,im.code+ov(r11),r7	/* unrelativize PC */
	jmp	(r7)		/* PC returned here */


/* frmfix - unravel frame, leaving return PC in r7 */

frmfix:	tstb	fr.ffb(r12)	/* is it a glued frame? */
	 blss	fixrel		/* no, fix real frame */
				/* GLUED FRAME */
	subl3	$(gfr.len<1),r12,r13	/* < flush glued frame from tp */
	mnegl	gfr.pc(r12),r7	/* get return PC out, negated */
	movl	gfr.fra(r12),r12 /* restore old FR */
	rsb

				/* REAL FRAME */
fixrel:	subl3	$fr.len*2,r12,r13 /* < flushing frame */
9:	movl	fr.fra(r12),r12	/* restore FR */
	movl	r12,r3		/* save FR in case we change it */
	bsbw	ungfrm		/* back up to unglued frame */
	pushl	r12		/* save unwound frame */
	cvtwl	fr.sp(r12),r8	/* get saved SP */
	 beql	1f
	addl2	r12,r8		/* unrelativize */
1:	cmpl	spsto,r8	/* need to unbind? */
	 jeql	2f		/* not if current binding same as this frame */
	  movl	r3,r12		/* get the right frame back */
	  bsbw	iunbnx		/*  unbind */
2:	movl	(sp)+,r12	/* get the unglued frame back */
	movl	fr.msa(r12),r2	/* find the MSUBR */
	movl	ms.im+ov(r2),r2	/*  IMSUBR atom */
	movl	a.gbind(r2),r2	/* its GBIND */
	movl	ov+gb.obj(r2),r11 /* its IMSUBR to MS */
	movl	fr.pc(r12),r7	/* return PC in known place */
	 jleq	1f
	subl3	r7,im.code+ov(r11),r7
1:	movl	r3,r12		/* and restore possible changed frame */
/* Do tracing here, so don't get 69 things from glued calls */
	tstl	mtrace		/* looking for trace? */
	 beql	2f		/* no, skip it */
	decl	mdepth		/* reduce depth of nesting */

	pushr	$bit0+bit1+bit3+bit5+bit12 /* save registers used for print */
	bsbw	prspac		/* print many spaces */
	movl	$lesst,r1	/* print a less-than at return */
	movl	$1,r3		/* that's just 1 character */
	clrl	r5		/* to tty */
	bsbw	print		/* print the sucker */

	bsbw	ungfrm
	movl	fr.msa(r12),r1	/* point to msubr */
	movl	ms.name+ov(r1),r1 /* point to atom */
	movzwl	10(r1),r3	/* get character count */
	movq	8(r1),r0	/* string pointer */
	clrl	r5		/* channel 0 */
	bsbw	print		/* print MSUBR name */
	movl	$crlf,r1
	movl	$2,r3		/* 2 characters */
	clrl	r5		/* to terminal */
	bsbw	print		/* print crlf */
	popr	$bit0+bit1+bit3+bit5+bit12 /* restore dem registers */
	
2:	rsb

/* iunbind - unbind entry from external world
*
* call:	r1/ saved SP pointing to binding
*	(may mung all registers except r0-r1 pair)
* return:
*	(unbinding done) */

iunbind: movl	r1,r8		/* put SP in known place */
				/* drop through into internal routine */
iunbnx:	movl	spsto,r6	/* get current SP */
	clrl	r2		/* clear "last binding" slot */
iunbnl:	cmpl	r6,r8		/* are we done? */
	 bleq	iunbnd
	movl	lb.atom(r6),r9	/* point to atom */
	 jeql	un.1		/*  none */
	cmpl	r9,uwatm	/* unwinder? */
	 jeql	dounwi		/*  yes - unwind */

unjoin:	movl	lb.last(r6),a.lbind(r9)	/* get last binding */
un.1:	movl	r6,r2
	movl	lb.prev(r6),r6	/* next binding */
	brb	iunbnl		/* loop */

iunbnd:	movl	r6,spsto	/* store current binding */
	rsb
/* this used to fixup tp, but clr claims it don't have to no more */

dounwi:	movl	lb.obj+4(r6),r7		/* get object out of binding (frame) */
	 jeql	unjoin			/* isn't one */
	movl	fr.msa(r7),r9		/* setup pointer to msubr */
	movl	ov+ms.im(r9),r9		/*  IMSUBR atom */
	movl	a.gbind(r9),r9		/* its GBIND */
	movl	ov+gb.obj(r9),r11	/* its IMSUBR to MS */
	addl3	ov+ms.im(r11),16(r6),r9	/* point to code  and offset*/
		/* the offset is stored in the DECL word by the compiler */
	addl3	$ln.bindb,r6,r13	/* keep room for binding */
	cmpw	(r13),$t.frame		/* is it followed by a frame pointer */
	 jneq	1f			/* no */
	movl	4(r13),r7		/* then that's the real McCoy */
	addl2	$8,r13			/* preserve it */
1:	movq	r0,(r13)+	/* push r0 & r1 to save return over unwinder */
	movl	$(fr.len<17+t.frame),(r13)+ /* > don't ask me... */
	movl	r12,(r13)+
	movl	$(ln.bind<16+t.bind),(r13)+ /* > */
	movl	r8,(r13)+
	movl	r7,r12
	movl	r6,spsto
	jmp	0(r9)			/* call unwinder */

/* here to exit from unwinder */

unwcnt:	movl	-4(r13),r8		/* restore saved registers */
	movl	-12(r13),r12
	subl2	$16,r13			/* fix stack */
	movq	-(r13),r0		/* restore real return values */
	movl	spsto,r6
	movl	r12,r3			/* for FRMFIX */
	movl	uwatm,r9
	brw	unjoin			/* rejoin common code */

/* iactiv - setup activation 

	(saves all registers)	*/

iactiv:	pushl	r0			/* save callers r0 */
	subl3	im.code+ov(r11),4(sp),r0	/* relativize calling pc */
	pushl	r12			/* save in case it changes */
	bsbw	ungfrm			/* find real frame */
	movl	r0,fr.act(r12)		/* smash PC into frame */
	subl3	r12,r13,r0
	addw3	$8,r0,fr.tp(r12)		/* and TP */	
	bisb2	$ffbit,fr.ffb(r12)	/* make sure still a full frame */
	movl	$fr.len<16+t.frame, (r13)+ /* push (possible glued) frame */
	movl	(sp)+,r12			/* restore FR */
	movl	r12,(r13)+
	movl	(sp)+,r0			/* and r0 */
	rsb

/* iretry - retry a frame 
call:
	r1/ frame to retry	*/

retry:	movl	r1,r12			/* new frame pointer */
	pushl	fr.msa(r12)
	pushl	r1			/* save for TP computation */
	movw	fr.arg(r12),-(sp)		/* save some stuff */
	bsbw	frmfix			/* fixup */
	bsbw	iframe			/* create a frame */
	clrl	r0
	movzwl	(sp)+,r1		/* get back fr.arg count */
	ashl	$3,r1,r0		/* times 8 for byte count */
	addl3	r0,(sp)+,r13			/* correctly */
	pushl	r12			/* save in case clobbered */
	bsbw	ungfrm			/* get real frame */
	movl	fr.pc(r12),r2		/* get PC */
	movl	(sp)+,r12		/* restore FR */
	movl	(sp)+,r4		/* get saved msubr to r4 for icret */
	movl	r1,r0			/* put number of arguments in r0 */
	brw	icret			/* r0 has number of args still... */

/* sblock - ublock for stack
* call:
*	r0/ type of structure
*	r1/ # of frobs on stack (not same as size)
* return:
*	r0/ count,,type
*	r1/ pointer to structure
On return, the structure will be on the top of stack, with the arguments
popped, and appropriate dope words surrounding it.  For the vector case,
this just calls ituple.
This must preserve all acs except 0 and 1.

Stack objects other than tuples have two identical dope words, one at the
beginning and one at the end.  The dope words are in the usual form of
length,,type+dopebit
nexts (of the GC) presumably will see the first one and skip the whole
structure; things like top need the second one.  The length field is, as
usual, the number of words in the whole structure, including dope words. */

sblock:	pushr	$bit2+bit3+bit4+bit5+bit6	/* save some acs */
	bicb3	$0374,r0,r2	/* isolate primtype */
	caseb	r2,$0,$3	/* dispatch to special code */
sbd:	.word	sblb-sbd	/* bytes */
	.word	sbls-sbd	/* string */
	.word	sblu-sbd	/* uvector */
	.word	sblv-sbd	/* vector */
	bsbw	comper

sblv:	bsbw	ituple		/* just like tuple */
	movw	$t.vec,r0	/* except really a vector */
sbret:	popr	$bit2+bit3+bit4+bit5+bit6	/* restore acs */
	rsb

/* for uvectors, we know that the returned structure will fit in the
   space used by the pushed args (unless there aren't any), since each
   arg takes two words on the stack and will only take one in the
   uvector.  This isn't true for strings and bytes */
sblu:	pushl	r1		/* save count */
	ashl	$3,r1,r0	/* # bytes used by args */
	subl3	r0,r13,r0	/* point to first arg */
	movl	r0,r2		/* save pointer */
	addl2	$2,r1		/* add space for dope words */
	ashl	$16,r1,r1
	movw	$t.uvec+dope,r1	/* here's the dope word */
	movl	r1,(r0)+	/* stuff it out */
	pushl	r0		/* this will be the return pointer */
	movl	4(sp),r3
	 jeql	3f		/* empty structure */
2:	movl	4(r2),(r0)+	/* move an element */
	addl2	$8,r2
	sobgtr	r3,2b		/* done? */
3:	movl	r1,(r0)+	/* push bottom dope word */
	movl	r0,r13		/* update stack pointer */
	movl	(sp)+,r1	/* pick up pointer */
	movl	(sp)+,r0
	ashl	$16,r0,r0
	movw	$t.uvec,r0
	brw	sbret		/* all done */

sblb:	movl	$t.bytes,r5	/* type word */
	brb	sbls1
sbls:	movl	$t.str,r5
sbls1:	pushl	r1		/* save count */
	ashl	$3,r1,r0	/* # bytes */
	subl3	r0,r13,r0	/* pointer to arg block */
	pushl	r0		/* save pointer for second pass */
	clrl	r2		/* count */
	tstl	r1
	 jeql	4f		/* nothing to look at? */
1:	bitb	$7,(r0)		/* check SAT of first arg */
	 jneq	3f		/* structured */
	incl	r2		/* character, just add one */
2:	addl2	$8,r0
	sobgtr	r1,1b
	brb	4f
3:	addw2	2(r0),r2	/* add length of frob */
	brb	2b
/* r2 has number of elements in new structure; 4(sp) is number of arguments;
   (sp) is pointer to beginning of arg block on stack.  r0 points just past
   end of arg block on stack.  r5 is type code */
4:	addl3	$11,r2,r3
	bicb2	$3,r3		/* number of bytes needed */
	ashl	$14,r3,r4	/* number of words in LH */
	movw	r5,r4
	bisl2	$dope,r4	/* r4 is dope word */
	tstl	r2
	 jeql	5f		/* empty string */
	addl2	(sp),r3		/* get pointer to new home for args */
	ashl	$3,4(sp),r0	/* number of bytes in arg block */
	pushr	$bit2+bit3+bit4	/* save registers */
	movc3	r0,*12(sp),(r3)	/* move args up stack */
	movl	r1,r13		/* update tp */
	popr	$bit2+bit3+bit4	/* restore registers */
5:	movl	(sp),r1
	movl	r4,(r1)+	/* first dope word */
	movl	r1,(sp)		/* pointer to new structure */
	tstl	r2
	 jeql	8f		/* empty string, so nothing to copy */
/* r3 is pointer to arg block, 4(sp) is number of args, r1 is pointer to
   structure, r4 is dope word */
	movl	4(sp),r5	/* get number of args back */
6:	bitb	$7,(r3)		/* see if arg is structured */
	 jneq	8f		/* yes */
	movb	4(r3),(r1)+	/* no, just copy a byte */
7:	addl2	$8,r3		/* update arg pointer */
	sobgtr	r5,6b		/* done? */
	bicl3	$-4,r2,r3	/* get number of bytes mod 4 */
	 jeql	1f		/* even, no padding needed */
	subl2	$4,r3
2:	clrb	(r1)+		/* padding byte */
	aoblss	$0,r3,2b
1:	movl	r4,(r1)+	/* stuff out dope word */
	movl	r1,r13		/* update tp */
	movl	(sp)+,r1	/* pop pointer */
	ashl	$16,r2,r0
	bicw3	$dope,r4,r0	/* make up pointer */
	addl2	$4,sp		/* clean up stack */
	brw	sbret	
8:	movzwl	2(r3),r0	/* get length of string to copy */
	 jeql	7b		/* empty, so skip it */
	movl	4(r3),r6	/* get pointer */
9:	movb	(r6)+,(r1)+	/* copy a byte */
	sobgtr	r0,9b		/* decrement count */
	brw	7b		/* done with this string */

/* uninitialized stack objects.  r0 is type, r1 is # of elements in
   returned object. */

usblock:
	pushl	r2
	bicb3	$0374,r0,r2	/* isolate primtype */
	caseb	r2,$0,$3	/* dispatch */
usbd:	.word	usblb-usbd
	.word	usbls-usbd
	.word	usblu-usbd
	.word	usblv-usbd

usblb:	movl	$t.bytes,r0	/* type */
	brb	usbls1
usbls:	movl	$t.str,r0
usbls1:	addl3	$3,r1,r2
	bicb2	$3,r2		/* number of bytes, exclusive of dope words */
usblg:	pushl	r3		/* protect previous contents */
	addl3	$8,r2,r3	/* allow for dope words */
	ashl	$14,r3,r3	/* number of words in LH */
	movw	r0,r3
	bisl2	$dope,r3	/* turn on dope bit */
	movl	r3,(r13)+	/* push first dope word */
	pushl	r13		/* pointer */
	addl2	r2,r13
	tstl	r2
	 jeql	1f		/* don't clobber if empty structure */
	clrl	-4(r13)		/* zero last word, so topus can work */
1:	movl	r3,(r13)+	/* second dope word */
	ashl	$16,r1,r1
	movw	r0,r1
	movl	r1,r0		/* make type word */
	movl	(sp)+,r1	/* restore pointer */
	movl	(sp)+,r3	/* restore saved acs */
	movl	(sp)+,r2
	rsb

usblu:	movl	$t.uvec,r0
	ashl	$2,r1,r2	/* number of bytes needed */
	brw	usblg		/* go build it */

usblv:	ashl	$16,r1,r2
	movw	$t.vec,r2	/* type word */
	pushl	r1		/* save length */
	movl	r2,r0
	movl	r13,r1
	pushr	$bit3+bit4+bit5
	bsbw	vecclr		/* zero the vector */
	ashl	$3,12(sp),r2	/* get number of bytes */
	addl2	r1,r2		/* point to dope words */
	addl3	$1,12(sp),r3
	ashl	$17,r3,r3
	movw	$t.vec+dope,r3
	movl	r3,(r2)
	popr	$bit3+bit4+bit5	/* first dope word */
	addl2	$4,sp
	clrl	4(r2)
	moval	8(r2),r13	/* update tp pointer */
	movl	(sp)+,r2
	rsb

/* ituple 
* call:
*	r1/ size of tuple
* return:
*	r0/ count,,type
*	r1/ pointer to tuple	*/

ituple:	pushl	r1
	ashl	$3,r1,r0	/* get byte count of tuple into r0 */
	subl3	r0,r13,r1	/* point to tuple */
	addl2	$8,r0
	ashl	$14,r0,r0	/* dope word has total # words */
	movw	$t.tuple+dope,r0 /* make it a doped tuple for stack */
	movl	r0,(r13)+	/* push on TP stack */
	clrl	(r13)+		/* dope words up */
	movl	(sp)+,r0
	ashl	$16,r0,r0
	movw	$t.tuple,r0
	rsb			/* and return */

/* irtuple - return a tuple to a frame
*  mretur  - same thing for special multi-return case
* call:
*	r1/ number of args
*	r2/ frame
*	r7/ still has return address from someplace
* return:
*	r0/ cnt,, type (=tuple)
*	r1/ pointer to tuple		*/

mretur:	pushl	$1		/* flag saying this mreturn */
	brb	mret2
irtuple:
	clrl	-(sp)		/* flag saying rtuple */
mret2:	tstl	r2		/* get target frame */
	 jneq	1f		/* is frame arg 0?*/
	movl	r12,r2		/* use current frame */
1:	movl	r2,r3		/* save orig frame */
2:  	tstb	fr.ffb(r2)	/* is it a glued frame? */
	 jgeq	grtupl		/* yes, special handling */
	tstl	(sp)		/* jump if rtuple */
	 jeql	mret3
	cmpl	fr.head(r2),$fr.len<16+dope+t.sframe
	 jeql	mret3		/* if this is a seg call, go return */
	movl	fr.fra(r2),r2
6:	tstb	fr.ffb(r2)
	 blss	5f
	movl	fr.act(r2),r2
	brb	6b

5:	movl	fr.msa(r2),r4	/* point to msubr */
	movl	ms.im+ov(r4),r4	/* IMSUBR atom */
	movl	a.gbind(r4),r4	/* GBIND */
	movl	gb.obj+ov(r4),r4	/* IMSUBR */
	movl	fr.pc(r2),r7	/* get this frames ret PC */
	subl3	r7,im.code+ov(r4),r7 /* get PC back */
	cmpw	$jmpa,(r7)	/* next ins absolute jump? */
	 jneq	4f
	cmpl	$8,2(r7)	/* to a return */
	 jneq	4f		/* nope, just return first value */
	movl	fr.fra(r2),r2	/* step back a frame */
	brb	2b		/* and try this guy */

/* here to do a comperr that eventually call interpreters MRETURN */

4:	ashl	$3,r1,r4
	subl3	r4,r13,r4	/* r4 now points to 1st elemet to return */
	bsbw	iframe		/* build a frame */

	movl	$ln.frame<16+t.frame,(r13)+	/* pass the frame */
	movl	r2,(r13)+

	movl	r1,r0		
	jeql	1f		/* if no args, go */

2:	movq	(r4)+,(r13)+
	sobgtr	r1,2b

1:	addl2	$1,r0		/* one more arg */
	movl	ecall,r1
	bsbw	mcallz		/* call it */
	brw	comper

mret3:	pushl	r1		/* save args */
	pushl	r13		/* and stack top */
	movl	r2,r12		/* now make it be current frame */
	bsbw	frmfix		/* fix frame */
	subl3	r7,im.code+ov(r11),r7
	movl	(sp)+,r8	/* restore stack top to r8 */
	movl	r13,r1		/* will be tuple pointer */
	movl	(sp)+,r0	/* and number of args */
	ashl	$3,r0,r3	/* make byte count */
5:	tstl	r0		/* see if no args */
	 jeql	1f		/* none? */
	subl2	r3,r8		/* make room for tuple */
2:	movq	(r8)+,(r13)+	/* push stuff */
	sobgtr	r0,2b		/* and iterate */
1:	tstl	(sp)+
	 jneq	2f
  	ashl	$13,r3,r0	/* shift count to left half */
	movw	$t.tuple,r0	/* bash type code in */
	jmp	(r7)		/* go to return address */

2:	ashl	$-3,r3,r1	/* num elements to r1 */
	movl	$t.fix,r0
	jmp	3(r7)

/* here to rtuple/mreturn from a glued frame */
grtupl:	subl3	$(gfr.len<1),r2,r3	/* < flush glued frame from tp */
	movw	gfr.typ(r2),r5		/* type of frame */
	addl3	gfr.pc(r2),im.code+ov(r11),r7		/* and un relativize */
	movl	gfr.fra(r2),r12		/* restore old FR */
	ashl	$3,r1,r0		/* # bytes to r0 */
	subl3	r0,r13,r0		/* point to first element */
	movl	r3,r4			/* copy of base */
	movl	(sp)+,r6		/* rtuple or mreturn */
	 jeql	igrtp3			/* its rtuple, don't fudge around */
	cmpw	$t.qsfra,r5		/* is this a seg call ? */
	 jneq	mret2			/* no check back */
igrtp4:	addl2	$3,r7			/* skip return */
igrtp3:	movl	r1,r8
	 jeql	1f
2:	movq	(r0)+,(r3)+
	sobgtr	r8,2b			/* and iterate */
	movl	r3,r13			/* fix tp */
  	tstl	r6			/* rtuple or mreturn */
	 jeql	3f
	movl	$t.fix,r0
	jmp	(r7)
3:	ashl	$16,r1,r0
	movw	$t.tuple,r0
	movl	r4,r1
	jmp	(r7)	

/* lckint - who knows ?? */

kerint:	tstl	ingc
	 jeql	2f
	rsb
2:	tstl	intflg
	 jneq	3f
	rsb
3:	movl	$t.word,(r13)+
	movl	(sp)+,(r13)+
	brw	rlckint
	
lckint:	tstl	ingc
	 jeql	2f	
	rsb
2:	movl	$t.fix,(r13)+
	subl3	(sp)+,im.code+ov(r11),(r13)+	/* save pc */
rlckint: pushl	r2
	clrl	cgnois
	clrl	cgct
lcklop:	ffs	$0,$32,intflg,r2
	pushr	$bit0+bit1
	locc	r2,intlen,intb1
	 jneq	3f
	popr	$bit0+bit1
	brw	noint
3:	bsbw	iframe
	movl	$t.fix,(r13)+
	movzbl	intb2(r0),(r13)+
	popr	$bit0+bit1
	movl	icall,r1	/* get frob */
	 jeql	losint
	movl	$1,r0
	ashl	r2,$1,r2
	bicl2	r2,intflg
	bsbw	mcallz
	tstl	intflg
	 jneq	lcklop
	movl	(sp)+,r2
	pushl	-(r13)
	cmpw	-4(r13),$t.fix	/* maybe relativize return pC*/
	 bneq	1f
	subl3	(sp),im.code+ov(r11),(sp)
1:	subl2	$4,r13
	rsb
noint:	ashl	r2,$1,r2
	bicl2	r2,intflg
	 jneq	lcklop
      	movl	(sp)+,r2
	pushl	-(r13)
	cmpw	-4(r13),$t.fix
	 bneq	2f
	subl3	(sp),im.code+ov(r11),(sp)
2:	subl2	$4,r13
      	rsb			/* return */

/* iagain 
* call:
*	r1/ frame pointer
* return:
				*/

iagain:	cmpl	r1,r12		/* same as current frame? */
	 jeql	again1		/* yes, skip unbinding */
	movl	r1,r12		/* new frame */
	bsbw	ungfrm		/* unglue */
	movzwl	fr.tp(r12),r8	/* get stack top */
	addl2	r12,r8		/* unrelativize */
	bsbw	iunbnx		/* unbind */
	movl	fr.msa(r12),r2	/* find the MSUBR */
	movl	ov+ms.im(r2),r2	/*  IMSUBR atom */
	movl	a.gbind(r2),r2	/* its GBIND */
	movl	ov+gb.obj(r2),r11 /* its IMSUBR to MS */
again1:	movl	fr.act(r12),r0	/* relative PC */
	bicl2	$bit31,r0	/* ffb bit in case it is set */
	addl2	ov+im.code(r11),r0
	movzwl	fr.tp(r12),r13	/* restore saved Tp */
	addl2	r12,r13
	movl	-4(r13),r12	/* pop the possible glued frame */
	jmp	(r0)		/* jump into code */

/* newtype - create a new type code
* call:
*	r1/ arg
* return:
*	r1/ new type code	*/

newtype: movl	type_count,r2	/* get current type count */
	incl	type_count	/* bump it */
	ashl	$6,r2,r2	/* put it into position */
	bicl2	$0xFFFFFFC0,r1	/* isolate primtype */
	bisl2	r2,r1		/* bash it in */
	rsb

/* typewc - return type code of type word
* call: r1/ type-w
* return: r1/ type-c
*/
typewc:	bicl2	$0xFFFF0000,r1	/* kill any length info */
	movl	$t.typc,r0
	rsb

/* typew - return type word
* call: r0/ type-c of frob; r1/ type-c of primtype
* return: r0, r1 type-w, value
*/
typew:	cmpzv	$0,$3,r1,$pt.rec	/* is primtype a record? */
	 jneq	1f
	ashl	$-3,r1,r1		/* get offset into table */
	movl	rectbl+4(r1),r1		/* get primtype's entry */
	movl	(r1),r1			/* pick up length */
	movw	r0,r1			/* stuff type code in rh */
	movl	$t.typw,r0
	rsb
1:	movl	r0,r1			/* Otherwise, just type-c */
	movl	$t.typw,r0		/* with a different type word */
	rsb

/********************************************************
*							*
*							*	
*		Storage Allocators			*
*							*	
*							*	
********************************************************/
		
/* blist - build list
* call:
*	r1/ number of elements
*	(tp) elements have been pushed on stack
* return:
*	r1/ pointer to list	*/

blist:	subl2	im.code+ov(r11),(sp)
	pushl	r1		/* save element count */
	jeql	2f		/* if none, done */

	clrl	r3		/* list to cons to */
1:	movl	-(r13),r1	/* pop an element */
	movl	-(r13),r0	/* from TP stack */
	bsbw	cons		/* cons it to list */
	movl	r1,r3		/* re-cons to same list */
	sobgtr	(sp),1b		/* and count down elements */

2:	movw	$t.list,r0
	addl2	$4,sp		/* discard element count on stack */
	addl2	im.code+ov(r11),(sp)
	rsb

/* bvector */

bvecto:	halt			/* not implemented */

/* birec - build record or string (zeroed) 
* call:
*	r1/ type
*	r3/ # words
*	r5/ # elements
* return:
*	r0/ type
*	r1/ pointer		*/

birec:	subl2	im.code+ov(r11),(sp)	/* relativize pc in case gc */
	bsbb	birecr			/* internal entry */
	addl2	im.code+ov(r11),(sp)
	rsb

birecr:	movl	r1,r8		/* save type code */
	movl	r3,r0		/* so we can setup arg to block */
	ashl	$2,r0,r7	/* make a pointer past allocated words */
	addl2	$2,r0		/* allocate n + 2 for dope words */
	bsbw	iblock		/* allocate storage (return in r6) */
	addl2	r6,r7		/* r7 now points to dope */
	movw	r0,2(r7)	/* block size in lh of dope word */
	movw	r8,(r7)		/* type in right half */
	bisw2	$dope,(r7)	/* with dope turned on */
	movl	r6,r1		/* put pointer to block in r1 for return */
	rotl	$16,r5,r0	/* count of elements in lh of r0 */
	movw	r8,r0		/* type in right half */
	rsb

/* uublock - allocate an unitialized user object (string, vector, uvector)
   called like ublock, except nothing on stack */

uublock:
	subl2	im.code+ov(r11),(sp)
	bicb3	$0374,r0,r2	/* primtype */
	movl	r1,r9		/* save length */
	caseb	r2,$0,$3
uubd:	.word	uublb-uubd	/* bytes */
	.word	uubls-uubd
	.word	uublu-uubd
	.word	uublv-uubd
	bsbw	comper

uublb:	movl	$t.bytes,r4
	brb	uubls1
uubls:	movl	$t.str,r4
uubls1:	movl	r1,r5		/* # elements */
	movl	r4,r1		/* type */
	addl3	r5,$3,r3	/* round up to next word */
	ashl	$-2,r3,r3
	bsbw	birecr		/* call record-builder */
uubret:	addl2	im.code+ov(r11),(sp)
	rsb

uublu:	movl	r1,r5		/* # elements */
	movl	r1,r3		/* # words */
	movl	$t.uvec,r1	/* type */
	bsbw	birecr		/* do it */
	brb	uubret		/* return */

/* vector has to be zeroed before return, to keep GC happy */
uublv:	movl	r1,r5
	ashl	$1,r1,r3	/* # words */
	movl	$t.vec,r1
	bsbw	birecr
	bsbb	vecclr		/* clear the vector */
	brb	uubret

/* clear a vector.  pointer is r0,r1; all other acs go away */
vecclr:	pushr	$bit0+bit1	/* save pointer */
	ashl	$-13,r0,r0	/* get # of bytes */
	movc5	$0,(r1),$0,r0,(r1)	/* zero the block */
	popr	$bit0+bit1	/* restore pointer */
	rsb

/* ublock - allocate a user object (string, vector, uvector)
* call:
*	r0/ type
*	r1/ length
*	(TP) elements are on stack
* return:
*	r0/ type
* 	r1/ pointer to object
*	(stack popped)		*/


ublock:	subl2	im.code+ov(r11),(sp)
	bicb3	$0374,r0,r2	/* isolate primtype */
	mnegl	r1,r7		/* negate count and copy to r7 */
	ashl	$3,r7,r7	/* double it and make byte count */
	addl2	r13,r7		/* r7 now points to first element */
	movl	r7,r9		/* save for restoring Tp */
	caseb	r2,$0,$3	/* dispatch on type */
ubd:	.word	ublb-ubd	/* byte string (same as string) */
	.word	ubls-ubd	/* string */
	.word	ublu-ubd	/* uvector */
	.word	ublv-ubd	/* vector */
	bsbw	comper		/* foo */

ublb:	movl	$t.bytes,r5
	brb	ubls1

/* string */

ubls:	movl	$t.str,r5	/* type */
ubls1:	clrl	r0
	pushl	r1		/* save # frobs on stack */
	tstl	r1
	jeql	4f		/* empty string */
1:	bitb	$3,(r7)
	jneq	3f
	incl	r0
2:	addl2	$8,r7
	sobgtr	r1,1b
	brb	4f
3:	addw2	2(r7),r0
	brb	2b
4:	movl	r0,r10		/* copy count for return */
	addl2	$11,r0		/* dope words, and round up to words */
	ashl	$-2,r0,r0	/* divide by 4 for words */
	bsbw	iblock		/* allocate that many words */
	movl	r6,r8
	movl	(sp)+,r1	/* get # elts on stack back */
	jeql	ublsdn		/* test for 0-length string */
	movl	r9,r7
1:	bitb	$3,(r7)
	jneq	3f
	movb	4(r7),(r8)+	/* dump a byte */
2:	addl2	$8,r7		/* next stack element */
	sobgtr	r1,1b		/* iterate for all chars in string */
	brb	ublsdn
3:	movzwl	2(r7),r2
	 jeql	2b
	movl	4(r7),r3
4:	movb	(r3)+,(r8)+
	sobgtr	r2,4b
	brb	2b
ublsdn:	ashl	$16,r0,r4	/* copy number of words to left half */
	movw	r5,r4		/* put right type in dope word */
	bisw2	$dope,r4
	addl2	$3,r8		/* put it on a longword boundary */
	bicl3	$3,r8,r0	/* by clearing low order bits */	
	movl	r4,(r0)		/* throw dopeword on stack */
	movl	r6,r1		/* pointer to block to return */
	brb	ubret		/* uniform place to return from */


/* uvector creation */
ublu:	movl	r1,r0		/* copy count */	
	addl2	$2,r0		/* dope words allocation */
	movl	r0,r4		/* arg for iblock */
	bsbw	iblock		/* allocate storage */

	movl	r6,r8		/* copy returned pointer */
	movl	r1,r10		/* copy count for return */
	jeql	2f		/* test for 0-length string */
1:	movl	4(r7),(r8)+	/* dump a word */
	addl2	$8,r7		/* next stack element */
	sobgtr	r1,1b		/* iterate for all chars in string */
2:	ashl	$16,r0,r4	/* copy number of words to left half */
	movw	$t.uvec+dope,r4	/* set type and dope bit */
	movl	r4,(r8)		/* throw dopeword on stack */
	movl	$t.uvec,r5	/* save type for return */	
	movl	r6,r1		/* pointer to block to return */
	brb	ubret		/* uniform place to return from */


/* vector generation */

ublv:	ashl	$1,r1,r1	/* number of words */
	movl	r1,r0		/* copy count */	
	addl2	$2,r0		/* dope words allocation */
	movl	r0,r4		/* arg for iblock */
	bsbw	iblock		/* allocate storage */

	movl	r6,r8		/* copy returned pointer */
	ashl	$-1,r1,r10	/* shift back and copy for return */
	jeql	2f		/* test for 0-length string */
1:	movl	(r7)+,(r8)+	/* dump a word */
	sobgtr	r1,1b		/* iterate for all chars in string */
2:	ashl	$16,r0,r4	/* copy number of words to left half */
	movw	$t.vec+dope,r4	/* set type and dope bit */
	movl	r4,(r8)		/* throw dopeword on stack */
	movl	$t.vec,r5	/* save type for return */	
	movl	r6,r1		/* pointer to block to return */
/* drop through to ubret */

ubret:	ashl	$16,r10,r0	/* copy count to left half */
	movw	r5,r0		/* and type to right */
	movl	r9,r13		/* restore TP */
	addl2	im.code+ov(r11),(sp)
	rsb

/* tmptbl - add a record description to table */

tmptbl:	ashl	$3,r0,r0	/* make long index */
	addl2	$rectbl,r0	/* pointer to table */
	movq	r1,(r0)		/* store info */
	rsb

/* record - build a record
* call:
*	r0/ type
* 	r1/ number of elements
*	(tp) elements on stack
* return:
*	(tp) popped
*	(record is built)	*/

record:	subl2	im.code+ov(r11),(sp)
	ashl	$-3,r0,r4	/* shift and copy type */
	bicl2	$037777360007,r4 /* mask uninteresting bits */
	movl	rectbl+4(r4),r8	/* table entry to r8 */
	movl	r0,r4		/* get type back again */
	pushl	r0		/* save r0 */
	movzwl	2(r8),r0	/* clear left half */
	ashl	$-1,r0,r0	/* div by 2 for storage allocation */
	movl	r0,r2		/* copy */
	addl2	$2,r0		/* dope words */
	bsbw	iblock		/* allocate storage */
	movl	(sp)+,r0	/* restore register */
	pushl	r11		/* save msubr pointer (being used as a temp) */
	pushl	r8		/* save another one */
	movl	r6,r11		/* save returned pointer */
	ashl	$16,r2,r3	/* count to left of r3 */
	movw	r4,r3		/* get type to right half */
	pushl	r3		/* and save for return */
	ashl	$2,r2,r2	/* make word index */
	addl2	r2,r11		/* point to dopewords */
	addl2	$0400000,r3	/* add 2 to left half (count) */
	movl	r3,(r11)	/* smash dope word to stack */
	bisl2	$dope,(r11)	/* dope it up */
	movl	r1,r9		/* save number of elements for loop */
	ashl	$3,r1,r1	/* word count */
	mnegl	r1,r1		/* negate it */
	addl3	r13,r1,r0	/* compute stack pointer */
	movl	r0,r11		/* and save it here */
	movl	r0,r5		/* save for stack fixup */
	movl	$4,r1		/* element number (word # for indexing mode) */

/* loop to move elements:
*	r6/ record
*	r7/ stack
*	r11/ tbl	*/

recorl:	movzwl	2(r8)[r1],r5	/* get dispatch code for put */	
	movzwl	(r8)[r1],r10
/*	ashl	$1,r5,r5	 and shift it */
	ashl	$1,r10,r10	/* both of its */
	movl	(r11),r3	/* value */
	movl	4(r11),r4
	bsbw	prcas		/* call appropriate move routine */
	addl2	$8,r11		/* step elements */
	addl2	$4,r1
	sobgtr	r9,recorl	/* loop */
	movl	r0,r13		/* reset TP */
	movl	(sp),r0		/* restore count and type */
	ashl	$1,r0,r0	/* make it number of words in left half */
	movw	(sp),r0		/* but don't shift type as well! */
	addl2	$4,sp		/* fix SP */
	movl	(sp)+,r8		/* restore registers */
	movl	r6,r1
	movl	(sp)+,r11		/* restore MS */
	addl2	im.code+ov(r11),(sp)	/* unrelativize */
	rsb

/* cons - build a list element
* call:
*	r3/ list to cons to
*	r0-r1/ value
* return:
*	r1/ result	*/

icons:	subl2	im.code+ov(r11),(sp)
	bsbb	cons
	addl2	im.code+ov(r11),(sp)
	rsb

cons:	movl	czone,r9	/* a zone set up? */
	 jeql	1f		/* no */
	  movl	gcpoff(r9),r4	/* yes, use it */
	  brb	consa
1:	 moval	rcl,r4 /* no zone */
consa:	movl	rcloff(r4),r9
	 jeql	cons1		/* get from iblock */
	movl	r9,r6
	movl	-4(r9),rcloff(r4) /* pull off chain */
	subl2	$4,r6		/* of free cons cells */
	brb	cons2

cons1:	movl	gcstopo(r4),r6
	addl2	$12,gcstopo(r4)	/* 12 bytes in list cell */
	cmpl	gcstopo(r4),gcsmaxo(r4)	/* GC needed? */
	 jleq	cons2		/* no, flush */
listgc:	movl	r6,gcstopo(r4)	/* restore used pointer */
	movq	r0,(r13)+	/* push thing being consed */
	movl	$t.list,(r13)+	/* push list */
	movl	r3,(r13)+
	movl	$3,r0
	bsbw	rungc		/* garbage collect */
	movl	-(r13),r3	/* get list back */
	subl2	$4,r13		/* flush list type word */
	movq	-(r13),r0	/* get object back */
	movl	czone,r9	/* has to be a zone after GC */
	movl	gcpoff(r9),r4
	brw	consa		/* try again */	
	
cons2:	movl	r3,0(r6)
	movq	r0,4(r6)	/* stuff object into list cell */
	movl	$t.list,r0	/* return type list */
	addl3	$4,r6,r1	/* return list */
	rsb

/* iblock - interface to storage allocation
* call:
*	r0/ number of words needed
* return:
*	r6/ pointer to block
*	(saves all other registers used)	*/

iblock:	bitl	r0,$0xffff0000
	 jeql	1f
	brw	comper
1:	pushr	$bit0+bit1+bit2+bit3+bit4+bit7	/* save a few registers */
iblokk:	movl	czone,r4	/* zone setup? */
	 beql	1f		/* not yet.. */
	  movl	gcpoff(r4),r4	/* yes, use it */
	  brb	2f
1:	movl	$gcpar,r4
2:	casel	r0,$2,$max_rcl-2	/* go to the right place */
ibtab:	.word	iblokl-ibtab
	.word	iblokl-ibtab
	.word	iblokl-ibtab
	.word	iblokb-ibtab
	.word	iblokb-ibtab
	.word	iblokl-ibtab
	.word	iblokl-ibtab
	.word	iblokb-ibtab
	.word	iblokl-ibtab
	jmp	iblokb
iblokl:	moval	rclvoff(r4),r7
	movl	(r7)[r0],r6	/* test to see if stuff is there */
	 jeql	iblokn		/* nope */
	movl	(r6),(r7)[r0]	/* splice out of chain */
	ashl	$2,r0,r0	/* convert to bytes */
	subl2	r0,r6		/* point above first word */
/*	ashl	$-2,r0,r0	pushed, so don't convert back */
	addl2	$4,r6		/* compensate for dope words */
				/* drop through... */
/* common return point */

iblokr:	popr	$bit0+bit1+bit2+bit3+bit4+bit7	/* restore a few registers */
	rsb


/* r0 has # words wanted, r4 has gc-params.  Return in r6 */

iblokb:	movl	rclvoff(r4),r2	/* anything in rclb? */
	 jeql	iblokn		/* no, allocate new */
	moval	rclvoff(r4),r6	/* previous pointer */
ibbnxt:	movzwl	-2(r2),r3	/* get first dope word */
	subl2	r0,r3		/* amount left */
	 blss	ibblos		/* not enough */
	 jeql	ibbeq		/* exactly right */
	subl2	$2,r3		/* must be 2 or more words left */
	 bgeq	ibbne		/* ok, win but with slop overflow */
ibblos:	movl	r2,r6		/* copy to previous slot */
	movl	(r6),r2		/* get next slot */
	jeql	iblokn		/* no more, allocate from free */
	brb	ibbnxt		/* try next slot */

/* exact match (we should be so lucky) */

ibbeq:	movl	(r2),(r6)	/* splice out of chain */
	decl	r0		/* fudge */
	ashl	$2,r0,r0	/* words--> bytes */
	subl2	r0,r2		/* point to beginning of block */
	
ibbret:	movl	r2,r6
	brb	iblokr		/* and go home winner */

/* inexact match, leave tailings */

ibbne:	movl	(r2),(r6)	/* splice out */
	addl2	$2,r3		/* compute new length of block */
	movw	r3,-2(r2)	/* new length of block */
	addl2	r0,r3
	pushl	r0		/* rclb expects pointer here, so save */
	movl	r2,r0		/* set up arg */
	bsbw	rclb		/* recycle the block */
	movl	(sp)+,r0		/* and restore reg */
	decl	r3
	ashl	$2,r3,r3
	subl2	r3,r2		/* point to beg of block */
	brb	ibbret

/* no recycling */

iblokn:	ashl	$2,r0,r0	/* turn into bytes */
	movl	gcstopo(r4),r6	/* return pointer */
	addl2	r0,gcstopo(r4)	/* bump up used marker */
	jvs	iblogc		/* if pointing into p2, need GC */
/*	ashl	$-2,r0,r0	no need to convert back, iblokr pops it */
	cmpl	gcstopo(r4),gcsmaxo(r4)	/* need to run GC? */
	 jleq	iblokr		/* no, return */
/*	brb	iblog1		need to convert length to words here */
iblogc:	ashl	$-2,r0,r0
iblog1:	movl	r6,gcstopo(r4)	/* restore used marker--not used yet */
	pushr	$bit1+bit5+bit8+bit9+bit10
	bsbb	rungc
	popr	$bit1+bit5+bit8+bit9+bit10
	brw	iblokk

/* rung - run users GC */

rungc:	pushl	r0
      	movl	czone,r1	/* must have a zone */
	 jeql	die
	bsbw	iframe
	movl	$t.fix,(r13)+
	movl	r0,(r13)+
	movl	$1,r0
	movl	gcfoff(r1),r1	/* pointer to gc function */
	bsbw	mcallz
	movl	(sp)+,r0
	rsb

/* EPA */

/* recycle a list cell (in r0, r1) */
rell:	pushl	r0
	movl	czone,r0
	 jneq	1f
	moval	-gcpoff+rcl,r0
1:	movl	gcpoff(r0),r0	/* gc-params */
	movl	rcloff(r0),-4(r1)	/* cdr pointer of new cell */
	clrq	(r1)		/* car pointer of new cell */
	movl	r1,rcloff(r0)
	movl	(sp)+,r0	/* don't step on any acs */
	rsb

/* recycle a record, in r0, r1 */
relr:	movq	r0,-(sp)	/* save acs */
	ashl	$-16,r0,r0	/* # halfwords in record */
	movaw	4(r1)[r0],r0	/* point to first dope word */
	bsbw	rclb		/* stuff it on the chain */
	movq	(sp)+,r0
	rsb

relu:	movq	r0,-(sp)
	bicb2	$0x0F8,r0	/* get primtype */
	caseb	r0,$4,$3	/* off we go */
relutb:	.word	reluby-relutb	/* bytes */
	.word	reluby-relutb	/* string */
	.word	reluuv-relutb	/* uv */
	.word	reluvc-relutb	/* vector */

reluby:	movzwl	2(sp),r0	/* get # bytes */
	addl2	$3,r0
	ashl	$-2,r0,r0	/* # longwords */
	jmp	reluc

reluuv:	movzwl	2(sp),r0
	jmp	reluc

reluvc:	movzwl	2(sp),r0
	ashl	$1,r0,r0
reluc:	moval	4(r1)[r0],r0	/* point to second dope word */
	bsbb	rclb		/* go do it */
	movq	(sp)+,r0
	rsb

/* call with pointer to second dope word of structure in r0 */
rclb:	movzwl	-2(r0),r1	/* block length */
	movw	$t.uvec+dope,-4(r0)	/* make sure a uv so msgc wins */
	subl2	$2,r1		/* # data words */
	 jleq	1f		/* nothing to zero */
	pushr	$bit0+bit1+bit2+bit3+bit4+bit5
	ashl	$2,r1,r1	/* # of bytes */
	subl2	r1,r0		/* points to 2nd word in block */
	movc5	$0,(r0),$0,r1,-4(r0)	/* zero the block */
	popr	$bit0+bit1+bit2+bit3+bit4+bit5
1:	addl2	$2,r1		/* actual # words in block */
	pushr	$bit2+bit3+bit4+bit5
	movl	czone,r2
	 jneq	2f
	moval	-gcpoff+rcl,r2
2:	movl	gcpoff(r2),r2	/* pick up gc-params */
	addl2	$rclvoff,r2
	clrl	r3
	cmpw	r1,$max_rcl
	 jgtr	3f
	addl2	rcltab[r1],r2	/* point at right slot */
	tstl	rcltab[r1]	/* are we a `long' block? */
	 jeql	3f		/* yes */
	mcoml	$0,r3		/* no, set the flag */
/* r0 points to 2nd dope word, r1 is block length, r2 is slot for recycle */
/* r3 is -1 if short block */
3:	tstl	(r2)		/* test chain for emptiness */
	 jneq	4f		/* not an empty chain */
	movl	r0,(r2)
	clrl	(r0)
rcldon:	popr	$bit2+bit3+bit4+bit5
	rsb
4:	movl	r2,r1		/* r1 is now something else */

/* r1 is pointer to current block of chain; r0 is pointer to block
being freed.  r2 becomes pointer to next block of chain. */

rclbl:	movl	(r1),r2
	 jeql	rclin1		/* at end of chain, just splice in */
	cmpl	r0,r2
	 blss	rclin		/* keep chain in ascending order */
	movl	r2,r1
	jmp	rclbl

rclin:	tstl	r3
	 jneq	rclin1		/* fixed-length block, just splice it */
	movzwl	-2(r2),r3	/* word length of next block */
/*	addl2	$2,r3		already have dope words included */
	ashl	$2,r3,r3
	subl3	r3,r2,r3	/* beginning of next block */		
	cmpl	r0,r3		/* adjacent blocks? */
	 jeql	1f
rclin1:	movl	r0,(r1)		/* no, splice into chain */
	movl	r2,(r0)
	jmp	rcldon
1:	addw2	-2(r0),-2(r2)	 /* adjacent, just update length */
	clrq	-4(r0)		/* zero the dope words */
	jmp	rcldon

rcltab:	.long	0
	.long	0
	.long	8	/* two-word blocks */
	.long	12
	.long	16
	.long	0	/* five-word */
	.long	0
	.long	28
	.long	32
	.long	0
	.long	40

/* setzon -- set current free storage zone 
   call:
	r1/	new zone or 0 to return the current
		if r1 is 0 and no zone, return UVECTOR of gcparams
*/
setzon:	tstl	r1		/* new one supplied? */
	jneq	1f		/* yes, set it up */

	movl	czone,r1	/* is there one to return? */
	jeql	2f		/* no return gcparams */

	movl	$(zlnt<16+t.zone),r0
	rsb

1:	movl	r1,czone
	tstl	ingc		/* were we in a GC? */
	 jeql	3f		/* no */
	tstl	cgnois		/* waiting for ctrl-G? */
	 jeql	3f		/* no */
	clrl	cgnois		/* clear the flag */
	pushr	$bit0+bit1+bit2+bit3+bit4+bit5
	moval	cgmsg2,r1
	movl	cgms2l,r3
	clrl	r5
	bsbw	print		/* print a message */
	popr	$bit0+bit1+bit2+bit3+bit4+bit5
3:	rsb

2:	movl	$gcpar,r1
	movl	$(gclnt<16+t.uvec),r0
	rsb

/****************************************************************
*								*
*								*
*			GC Stuff				*
*								*
*								*
****************************************************************/

/* swnxt -- sweep next
	call:	r0,r1 --> current object, and returned next object
	r2--> gc-params to use
*/

swnxt:	pushr	$bit2+bit3		/* save temp reg */
	tstl	r1		/* is this first time */
	bneq	1f		/* no, not first, time to sweep */

	movl	gcstopo(r2),r1	/* start at top */
1:	cmpl	gcsmino(r2),r1	/* see if done */
	blss	2f

	movl	$t.fix,r0	/* return 0 */
	clrl	r1
swret:	popr	$bit2+bit3
	rsb

2:	bicl2	$0xFFFFFFC0,r0	/* isolate primtype */
	cmpw	r0,$pt.list
	bneq	1f

	subl2	$4,r1		/* point to start of list */
1:	bitl	$dope,-8(r1)	/* dope word? */
	 bneq	1f		/* yes, more hair */
	movl	$t.list,r0	/* list, say so */
	subl2	$8,r1
	brb	swret

1:	movzwl	-6(r1),r0	/* get dw length */
	ashl	$2,r0,r2	/* to bytes */
	subl2	$2,r0		/* fixup count */
	ashl	$16,r0,r0
	bicw3	$dope+mark_bit,-8(r1),r3	/* get type */
	subl2	r2,r1		/* r1 point to start */
	bicl3	$0xFFFFFFC0,r3,r2
	caseb	r2,$0,$7
swtab:	.word	comper-swtab
	.word	comper-swtab
	.word	swrec-swtab
	.word	comper-swtab
	.word	swbyt-swtab
	.word	swbyt-swtab
	.word	swdone-swtab
	.word	swvec-swtab
	brw	comper
swbyt:	ashl	$2,r0,r0
	brb	swdone
swrec:	ashl	$1,r0,r0
	brb	swdone
swvec:	ashl	$-1,r0,r0
swdone:	bisw2	r3,r0		/* turn on type in return word */
	brb	swret

/* nexts -- sweep stack to find things to mark 
	call:	r1/ arg and return
		   if r1 --> 0 on call, return start of stack
		   if r1 --> 0 on return, sweep of stack done
*/

nexts:	pushl	r0		/* save extra register */
	tstl	r1		/* first time? */
	jneq	1f		/* no sweep */

	movl	czone,r0	/* get current zone */
	movl	gcpoff(r0),r0	/* point gc params */
	movl	$max_rcl,r1
2:	clrl	(r0)+
	sobgtr	r1,2b
	movl	tpstart,r1
	mcoml	$0,ingc		/* prevent ints for a while */

1:	movl	(r1),r0		/* examine last thing */
	bitl	$dope,r0	/* does last thing returned have dope word? */
	 jneq	7f		/* nope, no need to adjust */
	addl2	$8,r1		/* move to next guy */
	brb	4f		/* and check him out */

7:	cmpw	$dope+t.tuple,r0 /* just skip tuple dope words */
	 jeql	2f
	cmpw	$dope+t.vec,r0	/* in whatever form they come */
	 jeql	2f
	bicw2	$0xFFFF,r0	/* isolate length */
	rotl	$17,r0,r0	/* position and double length */
	addl2	r0,r1		/* point to end */
4:	movw	(r1),r0		/* get type code */
	bbsc	$5,r0,nxtdop	/* got a dope word */
	bitw	$7,r0		/* don't return words */
	 jeql	2f
nodop:	cmpw	$t.tuple,r0	/* tuple? */
	 jeql	2f		/* marked when encountered */
	cmpw	$t.qfram,r0	/* quick frame */
	 jneq	3f
	addl2	$gfr.len*2,r1	/* skip it */
	brb	4b
2:	addl2	$8,r1
	brb	4b
3:	cmpl	r13,r1		/* see if end of stack */
	 jgeq	nextrt
	clrl	r1
nextrt:	movl	(sp)+,r0
1:	rsb
nxtdop:	cmpw	$t.tuple,r0
	 jeql	2b		/* skip tuple dope words */
	cmpw	$t.vec,r0
	 jeql	2b
	cmpw	$t.qfram,r0	/* and glued frames */
	 jneq	9f
	addl2	$gfr.len*2,r1
	brw	4b
9:	cmpzv	$0,$3,r0,$pt.rec	/* other records get returned */
	 jeql	3b
	movzwl	2(r1),r0		/* get word length */
	ashl	$2,r0,r0		/* turn into bytes */
	addl2	r0,r1			/* move past this */
	brw	4b

/* get stack parameters.  Called with UV in r0/r1, returns it there. */
/* parameters are:  bottom of stack, top of stack, current max top of
   stack, absolute max top of stack (top of data space), top of buffer
   space, bottom of buffer space */
getstk:	movq	r0,(r13)+
	decw	-6(r13)
	 jlss	getskd
	movl	tpstart,(r1)+		/* get beginning of stack */
	decw	-6(r13)
	 jlss	getskd
	moval	-8(r13),(r1)+		/* current top of stack */
	decw	-6(r13)
	 jlss	getskd
	addl3	$tp_buf,tptop,(r1)+	/* max top of stack */
	decw	-6(r13)
	 jlss	getskd
	movl	tpmax,(r1)+
	decw	-6(r13)
	 jlss	getskd
	addl3	$pur_init,$prstart,(r1)+	/* top of buffer space */
	decw	-6(r13)
	 jlss	getskd
	moval	prstart,(r1)+		/* bottom of buffer space */
getskd:	movl	-(r13),r1
	subl2	$4,r13
	rsb

bigstk:	tstl	r1
	 jeql	1f			/* return current state */
	movl	stkok,r1
	movl	$1,stkok
	rsb
1:	movl	stkok,r1
	rsb

/* move stack.  Called with relocation in r0, assumes that all pointers
   except within frames/lbinds or at top level on stack (tuple pointers)
   will be updated by subsequent GC (which
   had better be pretty clever). */
movstk:	movl	tpstart,r1		/* bottom of stack */
movlop:	cmpl	r1,r13
	 jgeq	movdon
	bitl	$dope,(r1)		/* are we looking at a dope word? */
	 jneq	movdop			/* yes */
	cmpw	$t.qfram,(r1)
	 jeql	movqfr
	bitl	$7,(r1)			/* are we looking at a pointer? */
	 jeql	movldn			/* no, skip it */
	movl	4(r1),r2
	cmpl	r2,r13			/* pointer above top of stack? */
	 jgtr	movldn
	cmpl	r2,tpstart		/* below bottom? */
	 jlss	movldn
	addl2	r0,4(r1)		/* update the frob */
movldn:	addl2	$8,r1			/* and move on */
	brw	movlop
movdop:	bicl3	$dope,(r1),r2		/* turn off dope bit */
	cmpzv	$0,$3,r2,$pt.vec	/* tuples, vectors, etc. */
	 jeql	movldn
	cmpzv	$0,$3,r2,$pt.rec	/* see if a record */
	 jneq	movstr			/* no, just random structure */
	cmpw	$t.bind,r2		/* lbind */
	 jeql	movlbn
	addl2	$fr.len*2,r1		/* move to end of frame */
	addl2	r0,fr.fra(r1)		/* update frame pointer */
	brw	movlop
movstr:	ashl	$-14,r2,r2		/* get bytes in structure */
	addl2	r2,r1			/* update pointer */
	brw	movlop			/* and move on */
movlbn:	addl2	$4,r1
	movl	lb.prev(r1),r2
	cmpl	r2,r13
	 jgtr	1f
	cmpl	r2,tpstart
	 jlss	1f
	addl2	r0,lb.prev(r1)
1:	movl	lb.last(r1),r2
	cmpl	r2,r13
	 jgtr	2f
	cmpl	r2,tpstart
	 jlss	2f
	addl2	r0,lb.last(r1)
2:	addl2	$ln.bindb,r1		/* move to end */
	brw	movlop
movqfr:	addl2	$gfr.len*2,r1		/* move to end of glued frame */
	addl2	r0,gfr.pfr(r1)
	addl2	r0,gfr.fra(r1)		/* update pointers */
	brw	movlop
movdon:	addl2	r0,spsto	/* update binding chain start */
/* now blt the stack */
movagn:
2:	addl3	r0,tptop,arg1
	movl	$1,argn
	pushl	r0
	pushl	ap
	moval	argn,ap
	chmk	$_break
	movl	(sp)+,ap	/* get memory */
	movl	(sp)+,r0
	 jcs	movflt		/* frob failed */
	movl	tpstart,r1
	subl3	r1,r13,r2	/* current stack length */
	addl2	r0,tpstart
	movl	tpstart,stkbot
	movl	tpstart,r3
	addl2	r0,tptop	/* update kernel's stack pointers */
	movl	tptop,stkmax	/* save for compiled code to look at */
	addl2	r0,r13
	addl2	r0,r12
	movc3	r2,(r1),(r3)	/* blt the stack */
	rsb			/* all done */

movflt:	bsbw	nomem
	brw	movagn

nomem:	pushr	$bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit9+bit10+bit11+bit12
	moval	restlos,r1
	ashl	$16,restlol,r0
	mcoml	$1,r2		/* keep the loser from dying */
	bsbw	rfatal
	popr	$bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit9+bit10+bit11+bit12
	rsb

imarkr:	cmpl	r1,r13		/* anything on the stack is not marked */
	 jgtr	9f
	cmpl	r1,tpstart
	 jlss	9f
	rsb
9:	bicw2	$0xFFFF,r0
	rotl	$17,r0,r0	/* get length  times 2 from pntr */
	addl2	r0,r1		/* point to d.w. */
	tstl	r3		/* if unmark, jump */
	 jeql	1f
	bisw2	$0x8000,(r1)	/* mark it */
	clrl	4(r1)
	cmpl	$1,r3
	 jeql	2f		/* just mark it */
	movl	r3,4(r1)	/* store relocation */
2:	rsb
1:	bicw2	$0x8000,(r1)	/* kill bit */
3:	rsb

imarkrq:
	tstl	r0		/* check type ac */
	 jeql	3b		/* leave on zero type word */
	cmpl	r1,r13		/* anything on the stack is marked */
	 jgtr	1f
	cmpl	r1,tpstart
	 jgtr	4f
1:	pushl	r0
	bicw2	$0xFFFF,r0
	rotl	$17,r0,r0
	addl2	r0,r1
	movl	(sp)+,r0
	tstb	1(r1)		/* marked? */
	 jgeq	2f
	movl	4(r1),r1	/* any reloc pointer */
	 jneq	3f
4:	movl	$1,r1
1:	movl	$t.fix,r0
3:	rsb
2:	clrl	r1
	brb	1b
	

/****************************************************************
*								*
*								*
*			Structure manipulators			*
*								*
*								*
****************************************************************/

/* nthu - nth of string/ vector/ uvector
* call:
*	r0/ type
*	r1/ pointer
*	r2/ number
* return:
*	r0-r1/ type-value	*/

nthu:	bicl2	$0xFFFFFFFC,r0	/* isolate primtype */
	caseb	r0,$0,$3	/* dispatch on type */
nutab:	.word	nthub-nutab
	.word	nthus-nutab
	.word	nthuu-nutab
	.word	nthuv-nutab
	bsbw	comper		/* any other type is fatal */

nthub:	addl2	r2,r1
	movzbl	(r1),r1
	movl	t.fix,r0
	rsb

nthus:	addl2	r2,r1		/* point to byte */
	movzbl	(r1),r1		/* get byte */
	movl	t.char,r0	/* type char */
	rsb

nthuu:	ashl	$2,r2,r2	/* make index */
	movl	(r2)[r1],r1	/* get thing */
	movl	t.fix,r0	/* type fix */
	ashl	$-2,r2,r2	/* restore number (why?) */
	rsb

nthuv:	ashl	$3,r2,r2	/* make index */
	movl	-8(r2)[r1],r0	/* get type */
	movl	-4(r2)[r1],r1	/* get thing */
	ashl	$-3,r2,r2	/* restore number */
	rsb

/* nthr - nth of a record
* call:
*	r0/ type
*	r1/ pointer to record
*	r2/ element number
* return:
*	r0,r1/ type,value	*/

nthr:	pushr	$bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
	movzwl	r0,r0		/* clear left-half junk */
	ashl	$-3,r0,r0	/* and flush prim-type part */
	moval	rectbl+4(r0),r7	/* point to table entry */
	ashl	$3,r2,r2	/* index for element number */
	movzwl	0(r7)[r2],r3	/* get word offset */
	movzwl	2(r7)[r2],r4	/* code for appropriate field */
	ashl	$1,r3,r3	/* shift left */
	movl	r1,r6		/* object address */
	caseb	r4,$1,$12		/* dispatch */
nrtab:	.word	nthrbb-nrtab		/* bool */
	.word	nthrer-nrtab		/* error */
	.word	nthrbb-nrtab		/* enumeration */
	.word	nthrbb-nrtab		/* subrange */
	.word	nthrbb-nrtab		/* subrange sbool */
	.word	nthrlf-nrtab		/* list/ fix */
	.word	nthrlf-nrtab		/* list/ fix (sbool) */
	.word	nthrs3-nrtab		/* struc with count */
	.word	nthrs3-nrtab		/* struc with count (sbool) */
	.word	nthrs2-nrtab		/* struc with fixed length */
	.word	nthrs2-nrtab		/* same (sbool) */
	.word	nthra-nrtab		/* any */
	.word	nthrhw-nrtab

/* out of range drops through to error */

nthrer:	bsbw	cmperr		/* die horrible death */

/* boolean, etc */

nthrbb:
/*	*** how to extract boolean? *** */
	bsbw	unimpl

				/* drop through to common return */

nthrts:	popr	$bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
	rsb


/* list, fix */

nthrlf:	movl	(r7)[r2],r0
	movl	(r6)[r3],r1
	brb	nthrts

/* 3 1/2 word structure */

nthrs3:	ashl	$16,(r6)[r3],r0		/* length to left half */
	movw	(r7)[r2],r0		/* type to right */
	movl	2(r6)[r3],r1		/* value */
	 jneq	nthrts			/* false? */
nthrfl:	movl	$t.false,r0		/* yes, store falst type */
	brb	nthrts

/* structure of known length */

nthrs2:	movl	(r7)[r2],r0		/* type */
	movl	(r6)[r3],r1		/* pointer */
	 jeql	nthrfl			/* return false? */
	brb	nthrts			/* no, just return */

/* any case */

nthra:	movl	(r6)[r3],r0		/* type */
	movl	4(r6)[r3],r1		/* value */
	brb	nthrts

/* special type-c case */

nthrhw:	ashl	$1,r3,r1
	cvtwl	(r6)[r1],r1		/* get type code or -1 */
	 jlss	1f			/* jump if false */
	movl	$t.typc,r0
	brb	nthrts

1:	clrl	r1
	movl	$t.false,r0
	brb	nthrts

/* restu - rest uv, v, str 
* call:
*	r0/ type
*	r1/ pointer
*	r3/ number 	*/

restu:	movl	r3,(r13)+		/* save count for return */
	movl	r0,(r13)+		/* save cnt, type */
	subw2	r3,-2(r13)		/* fix count for return */
	bicb2	$0x0FC,r0		/* isolate 2-bit primtype */
	caseb	r0,$0,$3		/* dispatch */
rstab:	.word	rstub-rstab	/* bytes */
	.word	rstus-rstab	/* string */
	.word	rstuu-rstab	/* uvec */
	.word	rstuv-rstab	/* vector */

	bsbw	cmperr			/* others lose */

/* vector */

rstuv:	ashl	$3,r3,r3		/* adjust count for vector thing */
	cmpl	r1,r13
	 bgtr	1f			/* above top of stack */
	cmpl	r1,tpstart
	 blss	1f			/* in pure space */
	movw	$t.tuple,-4(r13)	/* tuple - fix saved type */
	brb	rstdon			/* and done */
1:	movw	$t.vec,-4(r13)		/* vector - fix saved type */
	brb	rstdon			/* and done */

/* uvector */

rstuu:	ashl	$2,r3,r3		/* adjust count for uvec thing */
	movw	$t.uvec,-4(r13)		/* fix saved type */
	brb	rstdon

rstub:	movw	$t.bytes,-4(r13)
	brb	rstdon
/* string */

rstus:	movw	$t.str,-4(r13)		/* fix saved type */
					/* and drop through */
rstdon:	addl2	r3,r1			/* fix pointer by right amount */
	movl	-(r13),r0		/* restore fixed type word */
	movl	-(r13),r3		/* and restore count */
	rsb

/* back */

backu:	mnegl	r3,r3			/* its like a negative */
	bsbw	restu			/* rest */
	mnegl	r3,r3			/* restore r3 */
	rsb


/* top things */

topu:	pushl	r0			/* save type word for return */
	bicb2	$0x0FC,r0			/* isolate primtype */
	caseb	r0,$0,$3		/* dispatch */
toptab:	.word	topub-toptab
	.word	topus-toptab	/* string */
	.word	topuu-toptab	/* uvec */
	.word	topuv-toptab	/* vector */
				/* any others drop through */
	bsbw	cmperr		/* oops */

/* bytes */
topub:	pushl	r2
	movw	$t.bytes,r2
	brb	topus1

/* string */

topus:	pushl	r2
	movw	$t.str,r2
topus1:	movzwl	6(sp),r0	/* get length */
	addl2	r0,r1		/* point to dope word */
	cmpl	r1,tpstart
	 jlss	1f
	cmpl	r1,tpmax
	 jgtr	1f
	brw	topust		/* stack case */
1:	bicl3	$0xFFFFFFFC,r1,-(sp)	/* extra chars */
	addl2	$3,r1		/* round to full word boundary */
	bicb2	$3,r1
topsdn:	movzwl	2(r1),r0	/* total length to r0 */
	subl2	$2,r0		/* not counting dope words */
	ashl	$2,r0,r0
	subl2	r0,r1		/* point to top */
	tstl	(sp)
	 jeql	1f
	subl3	(sp),$4,(sp)
	subl2	(sp),r0
1:	addl2	$4,sp
	ashl	$16,r0,r0
	movw	r2,r0		/* string primtype */
	movl	(sp)+,r2
	addl2	$4,sp		/* fix stack */
	rsb
topust:	bbc	$0,r1,1f	/* jump if on halfword boundary already */
	addl2	$1,r1		/* otherwise, move to one */
	movl	$1,-(sp)	/* at least one byte in last word */
	brb	3f
1:	movl	$2,-(sp)	/* at least two bytes in last word */
3:	tstw	(r1)		/* if zero, haven't hit dopeword yet */
	 jneq	2f
	addl2	$2,r1		/* advance pointer to dope word */
	brw	topsdn
2:	addl2	$2,(sp)		/* already at dopeword, 2 more in last word */
	bicl2	$0xFFFFFFFC,(sp)	/* but never more than 3 */
	brw	topsdn

/* uvec */

topuu:	movzwl	2(sp),r0	/* get length */
	ashl	$2,r0,r0
	addl2	r0,r1
	movzwl	2(r1),r0
	subl2	$2,r0		/* don't count dope words */
	ashl	$2,r0,r0
	subl2	r0,r1
	ashl	$14,r0,r0
	bisw2	$t.uvec,r0
	addl2	$4,sp
	rsb

/* vector */

topuv:	movzwl	2(sp),r0
	ashl	$3,r0,r0
	addl2	r0,r1			/* get to dope words */
	movzwl	2(r1),r0		/* get count from dw */
1:	subl2	$2,r0
	ashl	$2,r0,r0
	subl2	r0,r1
	ashl	$13,r0,r0
	bisw2	$t.vec,r0		/* get type */
	addl2	$4,sp
	rsb

/* putu - put vector, etc 
* call:
*	r0/ type
*	r1/ pointer
*	r2/ element number
*	r3,r4/ new value
* return:
*	(new value in place)		*/

putu:	pushl	r0			/* save type for return */
	bicb2	$0x0FC,r0		/* isolate primtype */
	caseb	r0,$0,$3		/* dispatch */
putab:	.word	putus-putab
	.word	putus-putab
	.word	putuu-putab
	.word	putuv-putab

	bsbw	cmperr

/* string case */

putus:	movb	r4,(r1)[r2]		/* store byte */
	movl	(sp)+,r0
	rsb

putuu:	movl	r4,(r1)[r2]		/* index does right thing */
	movl	(sp)+,r0
	rsb

putuv:	movq	r3,(r1)[r2]		/* magic index mode */
	movl	(sp)+,r0
	rsb

/* put record type
* call:
*	(args as in PUTU)	*/

putr:	

	pushr	$bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
	movzwl	r0,r0		/* clear left-half junk */
	ashl	$-3,r0,r0	/* and flush prim-type part */
	moval	rectbl+4(r0),r8	/* point to table entry */
	ashl	$3,r2,r2	/* index for element number */
	movzwl	0(r7)[r2],r10	/* get word offset */
	movzwl	2(r7)[r2],r5	/* code for appropriate field */
	ashl	$1,r10,10	/* shift left */
	movl	r1,r6		/* object address */
	brb	1f
prcas:	pushr	$bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
1:	caseb	r5,$1,$12	/* dispatch */
prtab:	.word	putrbb-prtab		/* bool */
	.word	putrer-prtab		/* error */
	.word	putrbb-prtab		/* enumeration */
	.word	putrbb-prtab		/* subrange */
	.word	putrbb-prtab		/* subrange sbool */
	.word	putrlf-prtab		/* list/ fix */
	.word	putrlf-prtab		/* list/ fix (sbool) */
	.word	putrs3-prtab		/* struc with count */
	.word	putrs3-prtab		/* struc with count (sbool) */
	.word	putrs2-prtab		/* struc with fixed length */
	.word	putrs2-prtab		/* same (sbool) */
	.word	putra-prtab		/* any */
	.word	putrhw-prtab		/* special type-c hack */

/* out of range drops through to error */

putrer:	bsbw	cmperr		/* die horrible death */

/* boolean, etc */

putrbb:
	bsbw	unimpl

				/* drop through to common return */

putrts:	popr	$bit0+bit1+bit2+bit3+bit4+bit5+bit6+bit7+bit8+bit10
	rsb


/* list, fix */

putrlf:	addl2	r6,r10			/* calc address */
	movl	r4,(r10)		/* store value */
	brb	putrts

/* 3 1/2 word structure */

putrs3:	addl2	r6,r10			/* calculate address */
	cmpw	$t.false,r3		/* false? */
	 jeql	putrsx			/* naw */
	rotl	$16,r3,r3
	movw	r3,0(r10)
	movl	r4,2(r10)
	brb	putrts
putrsx:	clrw	(r10)
putrsy:	clrl	2(r10)
	brb	putrts

/* fixed length item */

putrs2:	cmpw	$t.false,r2		/* false? */
	jneq	putrlf			/* no */
	addl2	r6,r10
	brb	putrsy

/* any */

putra:	addl2	r6,r10
	movq	r3,(r10)
	brb	putrts

/* special type-c hack */

putrhw:	addl2	r6,r10			/* calculate address */
	cmpw	$t.false,r3
	 jeql	1f
	movw	r4,0(r10)		/* store type-c */
	brb	putrts

1:	mcomw	$0,0(r10)		/* indicate false */
	brb	putrts	

/* cinth */

cinth:	bicb2	$0x0F8,r0		/* isolate 3 bits */
	caseb	r0,$1,$6		/* dispatch */
cintab:	.word	cindbl-cintab
	.word	ciner-cintab
	.word	ciner-cintab
	.word	cinfby-cintab
	.word	cinbyt-cintab
	.word	cinuvc-cintab
	.word	cindbl-cintab
					/* errors drop through */
ciner:	bsbw	cmperr

cindbl:	movq	(r1),r0
	rsb

cinfby:	movzbl	(r1),r1
	movl	$t.fix,r0
	rsb

cinbyt:	movzbl	(r1),r1
	movl	$t.char,r0
	rsb

cinuvc:	movl	(r1),r1
	movl	$t.fix,r0
	rsb

/* cirst */

cirst:	pushl	r9
	extzv	$0,$3,r0,r9		/* get rightmost 3 bits */
	caseb	r9,$1,$6		/* dispatch */
cirtab:	.word	cirlst-cirtab
	.word	cirer-cirtab
	.word	cirer-cirtab
	.word	cirbyt-cirtab
	.word	cirstr-cirtab
	.word	ciruvc-cirtab
	.word	cirvec-cirtab
				/* errors */
cirer:	bsbw	cmperr

cirlst:	movl	$t.list,r0
	movl	-4(r1),r1
	movl	(sp)+,r9
	rsb

cirbyt:	incl	r1
	pushl	r0
	decw	2(sp)
	movl	(sp)+,r0
	movw	 $t.bytes,r0
	movl	(sp)+,r9
	rsb

cirstr:	incl	r1
	pushl	r0
	decw	2(sp)		/* fix count */
	movl	(sp)+,r0		/* is this a kludge? */
	movw	$t.str,r0
	movl	(sp)+,r9
	rsb

ciruvc:	addl2	$4,r1
	pushl	r0
	decw	2(sp)
	movl	(sp)+,r0
	movw	$t.uvec,r0
	movl	(sp)+,r9
	rsb

cirvec:	addl2	$8,r1
	pushl	r0
	decw	2(sp)
	movl	(sp)+,r0
	movw	$t.vec,r0
	movl	(sp)+,r9
	rsb

/* cigas */

cigas:	tstl	(r1)		/* test gval slot */
	jeql	1f		/* anything? */
	 rsb			/* yes, gassigned */
1:	movl	$t.false,r0	/* nope, return false */
	clrl	r1
	rsb

/* cigvl */

cigvl:	movl	(r1),r1		/* get gval */
	 jneq	1f
	  bsbw	cmperr
1:	movq	(r1),r0		/* get type and all */
	rsb

/* ciemp */

ciemp:	pushl	r0
	bicb2	$0x0F8,r0	/* isolate 3 bits */
	caseb	r0,$1,$6
cietab:	.word	cielst-cietab
	.word	cier-cietab
	.word	cier-cietab
	.word	cielen-cietab
	.word	cielen-cietab
	.word	cielen-cietab
	.word	cielen-cietab

cier:	bsbw	cmperr

cielst:	movl	(sp)+,r0
	tstl	r1
	 jneq	cieln1		/* non-skip return */
cieln2:	addl2	$3,(sp)		/* skip return (must skip a brw ins) */
cieln1:	rsb

cielen:	movl	(sp)+,r0
	cmpl	r0,$0xFFFF
	 jlequ	cieln2		/* skip */
	rsb			/* non-skip */

/* cimon */

cimon:	pushl	r0
	bicb2	$0x0F8,r0	/* isolate 3 bits */
	caseb	r0,$0,$7
cimtbl:	.word	cimtru-cimtbl
	.word	cielst-cimtbl	
	.word	cimtru-cimtbl
	.word	cimtru-cimtbl
	.word	cielen-cimtbl
	.word	cielen-cimtbl
	.word	cielen-cimtbl
	.word	cielen-cimtbl

cimtru:	movl	(sp)+,r0
	brb	cieln2		/* skip return */


/* fatal -- complain, then depart from mim */

efatal:	movl	$1,r2		/* this one will kill the process */
	bsbb	rfatal
	jmp	comper

dfatal:	mcoml	$1,r2
	bsbb	rfatal
	jmp	comper

rfatal:	pushr	$bit0+bit1+bit2+bit3+bit4+bit5
	moval	oldtty,r1
	bsbw	fixtty		/* get the tty back into shape */
	moval	fatmsg,r1
	movl	fatmsl,r3
	clrl	r5
	bsbw	print
	movl	4(sp),r1	/* get the string pointer back */
	clrl	r3
	movw	2(sp),r3
	bsbw	print
	popr	$bit0+bit1+bit2+bit3+bit4+bit5
	tstl	r2
	 jgeq	rfatex
	bsbw	leave
	moval	newtty,r1
	bsbw	fixtty
	rsb
rfatex:	movl	r2,arg1
	movl	$1,argn
	moval	argn,ap
	chmk	$_exit
	rsb

leave:	pushl	ap
	clrl	argn
	moval	argn,ap
	chmk	$_getpid
	movl	r0,arg1		/* only poke this process */
	movl	$17,arg2
	movl	$2,argn
	movl	$argn,ap
	chmk	$_kill
	movl	(sp)+,ap
	rsb

/* quit -- depart from mim.  Arg in r1; if >= 0, do exit */

quit:	pushl	r1
	moval	oldtty,r1
	bsbw	fixtty		/* fix up tty */
	movl	(sp)+,r1
	 jgeq	1f		/* jump if doing exit */
	bsbw	leave
2:	pushl	r1
	moval	newtty,r1
	bsbw	fixtty
	movl	(sp)+,r1
	rsb
1:	movl	$1,argn
	movl	r1,arg1
	pushl	ap
	movl	$argn,ap
	chmk	$_exit
	movl	(sp)+,ap
	brb	2b

/* Call with address in r1 of block for fixing/breaking tty */
fixtty:	tstl	(r1)
	 jneq	1f			/* jump if stuff is there */
	rsb
1:     	pushl	ap
	clrl	arg1
	movl	$tiocsetn,arg2
	addl3	$12,r1,arg3
	movl	$3,argn
	movl	$argn,ap
	chmk	$_ioctl			/* set sgttyb stuff */
	movl	$tioclset,arg2
	addl3	$8,r1,arg3
	movl	$3,argn
	movl	$argn,ap
	chmk	$_ioctl			/* local modes */
	movl	$tiocsetc,arg2
	movl	r1,arg3
	movl	$3,argn
	movl	$argn,ap
	chmk	$_ioctl			/* other characters */
	movl	$tiocsltc,arg2
	addl3	$18,r1,arg3
	chmk	$_ioctl			/* local characters */
	movl	(sp)+,ap
	rsb

/* Call with state structure in r0,r1; copy stuff out of oldtty if there,
   else return false */
gettty:	tstl	oldtty
	 jneq	1f
	movl	$t.false,r0
	clrl	r1
	rsb
1:	pushr	$bit0+bit1+bit2+bit3+bit4+bit5
	movc3	$6,oldtty,*4(r1)
	moval	oldtty,r0
	movl	4(sp),r1
	movl	8(r0),*12(r1)
	movc3	$6,12(r0),*20(r1)
	moval	oldtty,r0
	movl	4(sp),r1
	movc3	$6,18(r0),*28(r1)
	popr	$bit0+bit1+bit2+bit3+bit4+bit5
	rsb

/* Call with old state in r0, new in r1.  Structure pointed to is
   assumed to be TTSTATE, as defined in TTY package.  0-->nothing saved. */
savtty:	pushl	r1
	moval	oldtty,r1
	bsbw	dottys
	movl	(sp)+,r0
	moval	newtty,r1
	bsbw	dottys
	rsb

dottys:	tstl	r0
	 jneq	1f
	clrl	(r1)
	rsb
1:	pushr	$bit2+bit3+bit4+bit5
	pushl	r0
	pushl	r1
	movc3	$6,*4(r0),(r1)		/* copy chars */
	movl	(sp),r1
	movl	4(sp),r0
	movl	*12(r0),8(r1)
	movl	(sp),r1
	movl	4(sp),r0
	movc3	$6,*20(r0),12(r1)
	movl	(sp)+,r1
	movl	(sp)+,r0
	movc3	$6,*28(r0),18(r1)
	popr	$bit2+bit3+bit4+bit5
	rsb

/* save  r1 --> channel upon which to do save
   r2-->0 or frozen space
   r3-->0 or pure space */

isave:	movl	(sp),r0			/* return PC */
	bsbb	dosave
	cmpw	r0,$t.false
	 beql	isavou
	movl	$t.fix,r0
	clrl	r1
isavou:	rsb

/* This assumes that the current zone is set up and that the gc-params
   and areas are consistent. */
dosave:	movl	bindid,sbindid		/* save bindid */
	movl	spsto,sspsto		/* and spsto */
	movl	r0,(r13)+		/* push return PC */
	movl	r12,(r13)+		/* save frame */
	movl	czone,r4
	 jeql	nozone
	brb	csave
nozone:	bsbw	comper

/* routine to save a zone's vital statistics on the tp stack.  Increments
   r0 for each area saved */
zonect:	movl	gcaoff(r4),r4		/* pick up area list */
	 jeql	sloopd
sloop:	movl	4(r4),r5		/* pick up area */
	movl	amin(r5),r3		/* maybe empty zone */
	 jeql	sloopd
	movl	r3,(r13)+
	movl	abot(r5),(r13)+
	movl	amax(r5),(r13)+
	incl	r0
	movl	-4(r4),r4
	 jneq	sloop
sloopd:	rsb

csave:	clrl	r0
	pushl	r4
	pushl	r3
	pushl	r2
	movl	(sp),r4
	 jeql	1f
	bsbb	zonect			/* save params for atom zone */
1:	movl	4(sp),r4
	 jeql	2f
	bsbb	zonect			/* save params for pure zone */
2:	movl	8(sp),r4
	bsbb	zonect			/* main zone */
/* r0 has total count of areas */
	
	movl	r0,(r13)+		/* save count of areas */
	movl	r13,stktop		/* save TP */
	movl	$version,versav		/* save kernel version # */
	pushl	r1			/* save channel */
	movl	r1,r5			/* and pass to print */
	moval	savstrt,r1		/* start at savstrt */
	subl3	r1,$savend,r3		/* compute number of bytes */
	bsbw	print			/* write kernel vars out */
	cmpw	r0,$t.false
	 jeql	savlost
	movl	tpstart,r1		/* beginning of tp stack */
	subl3	r1,r13,r3		/* size of tp stack */
	movl	(sp),r5
	bsbw	print			/* write out tp stack */
	cmpw	r0,$t.false
	 jeql	savlost
	movl	(sp),r5			/* channel back */
	movl	4(sp),r4
	 jeql	1f
	bsbb	zonesv		/* save atom zone */
	cmpw	r0,$t.false
	 jeql	savlost
1:	movl	8(sp),r4
	 jeql	2f
	bsbb	zonesv
	cmpw	r0,$t.false
	 jeql	savlost
2:	movl	12(sp),r4
	bsbb	zonesv
	cmpw	r0,$t.false
	 jeql	savlost
	movl	(sp)+,r1
	bsbw	close		/* close channel */
	addl2	$12,sp		/* flush zones from stack */
4:	mull3	$12,-(r13),r2
	subl2	r2,r13		/* flush areas from tp stack */
	subl2	$8,r13		/* other stuff on tp */
	rsb
savlost:
	addl2	$16,sp		/* flush garbage from sp */
	brb	4b		/* clean up tp, return */

zonesv:	movl	gcaoff(r4),r4	/* list of areas */
	 jeql	zonesd		/* empty? */
2:	movl	4(r4),r3	/* get an area */
	movl	amin(r3),r1	/* bottom of area */
	 jeql	zonesd
	subl3	r1,abot(r3),r3	/* size of area */
	pushl	r4		/* save list */
	bsbw	print
	movl	(sp)+,r4	/* get list back */
	cmpw	r0,$t.false	/* print lost */
	 beql	zonesd
	movl	-4(r4),r4	/* rest it */
	 jneq	2b		/* loop if more */
zonesd:	rsb
	movl	(sp)+,r4	/* fix up sp */

/* irestor -- r1/ --> channel  */

irestor:
	bsbb	dorest
	tstl	r0
	 jeql	1f
	movl	r0,(sp)			/* dorest returns PC in r0 */
1:	movl	$t.fix,r0
	movl	$1,r1
	rsb

dorest:	pushl	r1			/* save channel */
	clrl	p1cur

	movl	$savstrt,r1
	movl	$8,r3
	movl	(sp),r5
	bsbw	read			/* read version number */
	cmpl	versav,$version
	 jneq	verlost			/* different version, lose immediate */

	movl	$savstrt+8,r1		/* point to first chunk */
	movl	$savend-savstrt-8,r3	/* kernel vars only */
	movl	(sp),r5			/* channel for read */
	bsbw	read			/* should now know size of stack etc */
	movl	sbindid,bindid		/* restore bindid */
	movl	sspsto,spsto		/* and spsto */

stkagn:	pushl	ap
	movl	tptop,arg1
	movl	$1,argn
	moval	argn,ap
	chmk	$_break			/* make sure have space for stack */
	movl	(sp)+,ap
	 jcc	2f
	bsbw	nomem
	brb	stkagn

2:	movl	tpstart,r1		/* now read TP stack */
	movl	r1,stkbot		/* save in user area */
	movl	tptop,stkmax		/* save stack limit in user area */
	subl3	r1,stktop,r3		/* compute length */	
	movl	(sp),r5
	bsbw	read			/* read in TP stack */

	movl	stktop,r13		/* get TP back */
	movl	-(r13),r0		/* number of areas */
	mull3	$12,r0,r1		/* number of bytes */
	subl3	r1,r13,r1		/* point to first */
	movl	r1,stktop		/* save, to flush this */
reslop:	pushr	$bit0+bit1		/* save acs */
	subl3	abot(r1),amax(r1),r5		/* length of area */
	movl	abot(r1),r3			/* beginning of area */
	cmpl	r3,$0x40000000		/* part of p1? */
	 jlss	1f
	subl3	r3,$0x7FFFFFFF,r1	/* yes, get distance from top of p1 */
	cmpl	r1,p1cur		/* already have that much? */
	 jleq	1f
vagain:	movl	p1lim,limits+4		/* No, grow p1 */
	movl	r1,p1cur		/* say we grew it */
	movl	r1,limits
	movl	$2,argn
	movl	$rlimit_stack,arg1
	moval	limits,arg2
	pushl	ap
	moval	argn,ap
	chmk	$_setrlimit		/* do system call */
	movl	(sp)+,ap
	 jcs	novirt			/* jump if failed */
1:	movc5	$0,(r3),$0,r5,(r3)	/* zero core */
	movq	(sp),r0			/* get acs back */
	subl3	abot(r1),amin(r1),r3		/* get length */
	movl	abot(r1),r1			/* bottom of area */
	movl	8(sp),r5		/* get channel back */
	bsbw	read
	popr	$bit0+bit1
	addl2	$12,r1
	decl	r0
	 jgtr	reslop			/* jump if more areas */

	movl	(sp)+,r1		/* get channel back */
	bsbw	close
	movl	stktop,r13		/* get the correct tp back */
	movl	-(r13),r12		/* restore frame */
	pushl	ap
	movl	$rlimit_data,arg1
	moval	limits,arg2
	movl	$2,argn
	moval	argn,ap
	chmk	$_getrlimit
	movl	limits+4,tpmax		/* absolute top of stack */
	movl	$rlimit_stack,arg1
	moval	limits,arg2		/* store structure */
	movl	$2,argn
	moval	argn,ap
	chmk	$_getrlimit		/* read stack limit */
	subl3	limits+4,$0x80000000,r0	/* to lowest address */
	ashl	$byts_page_sh,r0,r0	/* to page number */
/*	addl2	$1000,r0		what was this, anyway? */
	movl	pagpt1,r1
	pushl	r2
	movl	16(r1),r2		/* bot of GC space */
	movl	r0,(r1)	/* new "top of P0" */
	movl	r0,16(r1)	/* and start of "free" space" */
	subl2	r2,r0		/* new-old:  neg of diff in # pages  */
	subl2	r0,12(r1)	/* new page count */
	movl	(sp)+,r2
	movl	(sp)+,ap
	movl	-(r13),r0		/* get return PC back */
	clrl	noboot
	rsb

novirt:	bsbw	nomem
	brw	vagain

verlost:
	tstl	noboot			/* see if mudsub during startup */
	 bneq	vermud
	movl	(sp),arg1
	clrl	arg2
	movl	$L_SET,arg3
	movl	$3,argn
	pushl	ap
	moval	argn,ap
	chmk	$_lseek
	movl	(sp)+,ap
	brw	verlo1

vermud:	movl	$1,argn
	movl	(sp),arg1
	pushl	ap
	moval	argn,ap
	chmk	$_close			/* close save file */
	movl	(sp)+,ap

verlo1:	movl	versav,r0
	clrl	r1			/* make sure will work as quad */
	moval	verptr,r2
	movl	$1000,r3
1:	ediv	r3,r0,r4,r0		/* quotient to r1, remainder to r0 */
	 bneq	verls1
	divl2	$10,r3
	brb	1b
verls1:	addb3	r4,$48,(r2)+		/* deposit the byte */
2:	divl2	$10,r3
	 beql	verdon
	ediv	r3,r0,r4,r0
	addb3	r4,$48,(r2)+
	brb	2b
verdon:	clrb	(r2)
	moval	newker,r1
	movl	newkln,r3
	clrl	r5
	bsbw	print
	movl	argbeg,r2
	subl2	$4,r2
	tstl	noboot
	 beql	3f
	movl	argone,(r2)		/* if mudsub, get org jcl */
	brb	4f
3:	clrl	argone
	movb	(sp),argone
	moval	argone,(r2)		/* save file descriptor (funny str)*/
4:	movl	r2,arg2
	moval	kernam,arg1
	movl	envbeg,arg3
	movl	$3,argn
	pushl	ap
	moval	argn,ap
	chmk	$_execve		/* try to load the right kernel */
	moval	savver,r1		/* failed if get here */
	ashl	$16,savvel,r0
	bsbw	efatal
 
/* allocate pages */

mpages:	bsbw	cmperr			/* unimplemented */


/****************************************************************
*								*
*								*
*			Input/ Output				*
*								*
*								*
****************************************************************/

/* open - open a channel to a file
* call:
*	r0/ type (need string count for syscall)	
*	r1/ string pointer to file spec
*	r3/ fix (mode) 0=read, 1=write, 2=read/write
* return:
*	r0/ type (channel)
*	r1/ file-descriptor
*	(the file is positioned at byte 0)
*	(all registers saved)	*/

/* openz is just like open, except the string is already null-terminated */
openz:	pushr	$bit2+bit3+bit4+bit5
	movl	r1,arg1			/* dont copy file name */
	brw	open1

open:	pushr	$bit2+bit3+bit4+bit5	/* save a few scratch registers */
	ashl	$-16,r0,r0	/* get left halfword (count) */
	movc3	r0,(r1),(r13)	/* copy the string to the TP stack */
	clrb	(r3)		/* null terminate it */
	movl	r13,arg1	/* pointer to asciz string */
open1:	movl	$3,argn		/* set up number of args */
	pushl	ap		/* save register */
	moval	argn,ap	/* arg block */
	clrl	arg3
	movl	8(sp),arg2	/* get former r3 off stack */
	 jneq	1f		/* jump if write--this may not work, but isn't */
				/* used anyway */
	chmk	$_open		/* open the file */
	brb	2f
1:	movl	$0x1FF,arg3
	movl	$O_RDWR+O_CREAT,arg2
	chmk	$_open		/* create file */
/* note potential bug of leaving file open when shouldn't if chmod fails */
2:	movl	(sp)+,ap	/* restore linkage register */
	 bcs	1f		/* system call sets carry bit on failure */
	movl	r0,r1		/* return the file descriptor */
	movl	$t.chan,r0	/* type channel */
opnret:	popr	$bit2+bit3+bit4+bit5	/* restore registers bombed by movc3 */
	rsb

1:	movl	r0,r1		/* error code to r1 */
	movl	$t.fix,r0
	clrl	r3
	bsbw	cons
	movl	$t.false,r0	/* return false with reason */
	brb	opnret		/* common return */


/* close - close a channel
* call:
*	r1/ channel
* return:
*	r1/ 0 or false() if failed strangely */

close:	movl	$1,argn		/* count arguemtns to system */
	movl	r1,arg1		/* only arg is channel */
	pushl	ap		/* save register */
	movl	$argn,ap	/* arg block */
	chmk	$_close		/* close the file */
	movl	(sp)+,ap		/* restore linkage */
	 bcs	1f
	movl	r0,r1		/* move returned value */
	movl	$t.fix,r0	/* type fix means win */
	rsb
1:	movl	r0,r1		/* cons up a false */
	movl	$t.fix,r0
	clrl	r3
	bsbw	cons
	movl	$t.false,r0	/* type false loses */
	rsb

/* print - print string on file
* call:
*	r0,r1/ string
*	r3/ char count
*	r5/ channel
* return:
*	r0,r1/ number of bytes written, -1 for error */

print:	movl	$3,argn		/* count args */
	movl	r5,arg1		/* channel to arg block */
	movl	r1,arg2		/* string address */
	movl	r3,arg3		/* count of bytes */
	pushl	ap		/* save register */
	movl	$argn,ap	/* arg block */
	chmk	$_write
	movl	(sp)+,ap		/* restore linkage */
	bcs	prterr
	movl	r0,r1		/* number of bytes written */
	movl	$t.fix,r0	/* ok, return fix */
	rsb
prterr:	movl	r0,r1
	movl	$t.fix,r0
	clrl	r3
	bsbw	cons
	movl	$t.false,r0
	rsb

/* read - read a string
* call:
*	r0,r1/ string
*	r3/ number of characters
*	r5/ channel
* return:
*	r0,r1/ number of bytes read, -1 for error */

read:	movl	$3,argn		/* count of arguments */
	movl	r5,arg1		/* store channel */
	movl	r1,arg2		/* where to read to */
	movl	r3,arg3		/* how much to read */
	pushl	ap		/* save register */
	movl	$argn,ap	/* arg block */
	chmk	$_read
	movl	(sp)+,ap		/* restore linkage */
	movl	r0,r1		/* save count of bytes read */
	movl	$t.fix,r0	/* to return as fix */
	rsb

/* pipe- funny handler, because returns two values.  Call with
   2-element UV in r0,r1, returns false with reason or uv. */

dopipe:	movq	r0,(r13)+
	pushl	ap
	moval	argn,ap
	clrl	argn
	chmk	$_pipe
	movl	(sp)+,ap
	bcs	nopipe
	movl	r0,*-4(r13)
	movl	-(r13),r0
	movl	r1,4(r0)
	movl	r0,r1
	movl	-(r13),r0
	rsb
nopipe:	movl	r0,r1
	movl	$t.fix,r0
	brw	syser

/* syscal -- general MIM interface to system calls in UNIX
* call:	args on tp stack,r1 ==> arg to chmk
*			 r0 ==> # of args
*		return value as a fix
*		       or false with reason
*	pops tp stack
*/
syscal:	movl	sp,r3			/* use stack for args */

	movl	r0,r4			/* catch degenerate case */
	 jleq	1f
2:	pushl	-(r13)			/* pop them from tp onto sp */
	subl2	$4,r13			/* flush type word */
	sobgtr	r0,2b

1:	pushl	r4
	pushl	ap			/* save arg pointer */
	moval	4(sp),ap 
	movl	ap,lstarg
	movl	r1,lstcal		/* save last call for funny stuff */
	cmpl	r1,$_wait		/* is this a wait call? */
	 jneq	2f			/* no, all's well */
	cmpl	r4,$1
	 jgtr	syswait			/* alas! */
2:	chmk	r1			/* execute sys call */
syser1:	movl	(sp)+,ap		/* restore arg pointer */
	movl	r3,sp			/* and pop stack */
	movl	r0,r1			/* return value */
	movl	$t.fix,r0
	 bcs	syser			/* was there really an error */
	rsb
syswait:
	movl	8(ap),r0
	movl	12(ap),r1
	bispsw	$0xf			/* this whole thing really sucks */
	chmk	$_wait			/* do it */
	jcs	syser1			/* lost */
	tstl	4(ap)
	 jeql	syser1
	movl	r1,*4(ap)		/* store status */
	brw	syser1	

syser:	clrl	r3
	bsbw	cons			/* cons it up */
	movl	$t.false,r0
	rsb

rntime:	pushl	ap
	movl	$2,argn
	moval	argn,ap
	moval	ruse,arg2
	clrl	arg1
	chmk	$_getrusage
	addl3	utime,stime,r0	/* number of seconds */
	addl3	utime+4,stime+4,r1	/* microseconds */
	cvtlf	r0,r0
	cvtlf	r1,r1
	divf2	$603998836,r1	/* F floating 1000000 */
	addf2	r0,r1
	movl	$t.float,r0
	movl	(sp)+,ap
	rsb	

/* interrupt interface to UNIX
   this routine is called by system when an interrupt occurs */

/* WARNING:  The following code contains violence and adult situations.
   Parental discretion is advised. */

.align	2				/* align start of int routine */

hndlr:	.word	0			/* register mask? */
	pushl	r0
	clrl	interr
	ashl	4(ap),$1,r0
	cmpl	4(ap),$sig_ttou
	 jeql	hndttou			/* do some funny stuff */
	mcoml	$1,interr		/* --> return error */
	movl	$EINTR,intval		/* with this error code */
	cmpl	4(ap),$sig_cont
	 jneq	1f
	tstl	icall
	 jeql	hdexit
1:	bisl2	r0,intflg
	tstl	runint
	 beql	2f			/* interruptable? */
	brw	3f
2:	cmpl	4(ap),$sig_int		/* was this ctrl-G? */
	 jneq	hdexit			/* no, nothing special */
	tstl	ingc			/* are we in a GC? */
	 jneq	hdcggc			/* yes */
	aoblss	$3,cgct,hdexit		/* not in GC, see if panic stop */
	movl	12(ap),r0		/* pick up sigcontext */
	movl	12(r0),intgpc		/* save return pc */
	moval	panic1,12(r0)		/* return to our code */
	movl	4(r0),intmsk
	moval	panic1,16(r13)		/* really return to our code */
	brw	hdexit
hdcggc:	tstl	cgnois
	 jneq	hdexit			/* already gave message */
	incl	cgnois			/* say we gave a message */
	pushr	$bit0+bit1+bit2+bit3+bit4+bit5
	moval	cgmsg1,r1
	movl	cgmsgl,r3
	clrl	r5
	bsbw	print
	popr	$bit0+bit1+bit2+bit3+bit4+bit5
hdexit:	movl	(sp)+,r0
  	ret
/* handle a panic stop--pc to return to is in intgpc */
/* get here by changing return PC in handler */
panic1:	moval	panic2,16(r13)		/* just get to next section */
	ret
panic2:	movl	$1,argn
	movl	intmsk,arg1
	pushl	ap
	moval	argn,ap
	chmk	$_sigsetmask		/* change the mask */
	movl	(sp)+,ap
	addl2	$16,sp
	moval	panic3,(sp)		/* return to final place */
	rei
panic3:	pushl	intgpc			/* save real return pc */
	cmpl	intgpc,$savstrt
	 jleq	panic4
	brw	lckint			/* and go cause an interrupt */
panic4:	brw	kerint			/* interrupted from kernel */

3:	pushr	$bit1+bit2+bit3
	movl	12(ap),r1		/* pick up sigcontext */
	movl	12(r1),r2		/* pick up PC */
	cmpb	(r2)+,$_chmk		/* is it a chmk? */
	 beql	intint
	brw	noskip			/* not a chmk */
intint:	movzbl	(r2)+,r3		/* pick up address byte */
					/* can be register, literal, immediate */
	cmpb	$0x8F,r3		/* immediate? */
	 jneq	4f
	movzwl	(r2)+,r3		/* pick up the frob */
	brb	6f
4:	cmpb	$0x40,r3		/* literal? */
	 jgtr	6f			/* yes, have value */
	bicl2	$0xF0,r3		/* isolate register number */
	 jeql	intfoo			/* R0 not on stack */
	cmpl	r3,$3
	 jleq	5f			/* not on stack */
intfoo:	ashl	r3,$1,r3		/* generate mask */
	pushr	r3			/* chomp */
	movl	(sp)+,r3		/* now have right AC in ac3 */
	brb	6f
5:	decl	r3
	movl	(sp)[r3],r3		/* pick up ac off stack */
6:	pushl	r4
	movl	intcml,r4
ckloop: decl	r4
	 jlss	9f
	cmpl	r3,intcmk[r4]
	 jeql	7f
	brb	ckloop
9:	movl	(sp)+,r4
noskip:	popr	$bit1+bit2+bit3		/* no, tough luck */
	movl	(sp)+,r0
	ret
7:	movl	(sp)+,r4
	movl	r2,12(r1)		/* update PC */
	movl	r2,(r13)+
	popr	$bit1+bit2+bit3
	addl2	$4,sp
	movl	-(r13),intpcs		/* pass new PC back down */
	movl	12(ap),r1
	movl	4(r1),intmsk		/* pass old mask back down */
	moval	intr1,16(r13)		/* return to our code */
	ret

intr1:	moval	intr2,16(r13)		/* again */
	ret

intr2:	movl	$1,argn
	movl	intmsk,arg1		/* restore old mask */
	pushl	ap
	moval	argn,ap
	chmk	$_sigsetmask
	movl	(sp)+,ap
	movl	intval,r0		/* return error code */
	addl2	$16,sp			/* clear crap off sp */
	movl	intpcs,(sp)		/* update PC */
	tstl	interr
	 jgtr	1f			/* only set error flag if interr -1 */
	bispsw	$1
	bisl2	$1,4(sp)
1:	rei				/* and done */

/* special code to handle sigttou, allowing writes to slip through,
   but ignoring everything else */
hndttou:
	mcoml	$1,interr
	movl	$EINTR,intval
	cmpl	lstcal,$_write		/* were we trying a write? */
	 jneq	3b			/* no, just interrupt out of call */
	pushl	ap
	movl	lstarg,ap
	chmk	$_write			/* should work this time */
	movl	r0,intval
	 jcs	1f
	movl	$1,interr		/* say no error on write */
1:	movl	(sp)+,ap
	brw	3b			/* now fall into skip code */

.set	itmsl, 0			/* length of message */
.set	itmsg, 4			/* pointer to message */
.set	itfat, 8			/* 1 if error is fatal */
.set	itesiz, 12
inttbl:	.long	0
	.long	0
	.long	0
	.long	intmsl
	.long	intmsg
	.long	0
	.long	qutmsl
	.long	qutmsg
	.long	0
	.long	ilomsl
	.long	ilomsg
	.long	1
	.space	itesiz	/* trace trap */
	.space	itesiz	/* IOT */
	.space	itesiz	/* EMT */
	.long	fpemsl
	.long	fpemsg
	.long	1
	.space	itesiz	/* kill */
	.long	busmsl
	.long	busmsg
	.long	1
	.long	segmsl
	.long	segmsg
	.long	1
	.long	sysmsl
	.long	sysmsg
	.long	1
	.space	itesiz	/* pipe */
	.space	itesiz	/* alarm clock */
	.space	itesiz	/* stop */
	.space	itesiz	/* tstop */
	.space	itesiz	/* continue */
	.space	itesiz	/* child */
	.space	itesiz	/* ttin */
	.space	itesiz	/* ttout */
	.space	itesiz	/* io possible */
	.long	cpumsl
	.long	cpumsg
	.long	1
	.long	fszmsl
	.long	fszmsg
	.long	1
	.space	itesiz	/* vtalarm */
	.space	itesiz	/* profiling timer alarm */

.align	2
hndseg:	.word	bit0+bit1+bit2+bit3+bit4+bit5
	pushl	ap
hndsg1:	movl	12(r13),r0
	cmpl	12(r0),8(r0)		/* want bigger of fr and tp */
	 jgtr	1f
	movl	8(r0),r0
	brb	2f
1:	movl	12(r0),r0
2:	subl3	r0,tptop,r0		/* how close are we to blowing stack? */
	cmpl	r0,$16
	 jgtr	hsreal			/* not close enough...*/
	cmpl	tptop,tpmax
	 jgeq	stkflt			/* sorry, stack's gonzo */
	addl3	$tp_buf,tptop,r1
	subl3	r1,tpmax,r3		/* max we can grow, allowing for buffer */
	cmpl	r3,$tp_buf
	 jgtr	1f			/* all OK */
	movl	$1,stkok		/* stack is at limit, basically */
	movl	tpmax,r2		/* so get a buffer, and ...*/
	movl	$1,r3			/* cause interrupt */
grostk:	movl	$1,argn			/* r2 has new tptop, r3 is non-zero */
	movl	r2,arg1			/* if interrupt should occur */
	moval	argn,ap
	chmk	$_break
	 jcs	stkflt			/* growth failed */
	movl	(sp)+,ap
	movl	r2,tptop
	tstl	r3
	 jeql	grosto			/* all done */
	tstl	icall
	 jeql	grosto			/* can't interrupt if no handler */
	ashl	4(ap),$1,r0
	bisl2	r0,intflg		/* cause an interrupt */
grosto:	ret
stkflt:	moval	stklos,r1
	ashl	$16,stklol,r0
	mcoml	$1,r2
	bsbw	rfatal
	brw	hndsg1			/* try again, may work */
/* come here if room to grow stack */
1:	tstl	stkok
	 jneq	2f			/* grow arbitrarily */
	addl3	$tp_buf,tptop,r2	/* get a buffer, and interrupt */
	movl	$1,r3
	brw	grostk
2:	addl3	$tp_buf,tptop,r2	/* grow some */
	clrl	r3			/* silently */
	brw	grostk
hsreal:	movl	$2,argn
	moval	limits,arg2
	movl	$rlimit_stack,arg1
	moval	argn,ap
	chmk	$_getrlimit		/* read stack limit */
	subl3	limits,$0x7fffffff,r3	/* get bottom of stack area */
	movl	$sig_segv,arg1
	moval	hndseg1,sgvec
	clrl	sgvec+4
	clrl	sgvec+8
	moval	sgvec,arg2
	chmk	$_sigvec		/* change segmentation handler */
	movl	(sp)+,ap
	movl	12(sp),r1
	movl	4(r1),arg1
	pushl	ap
	movl	$1,argn
	moval	argn,ap
	chmk	$_sigsetmask		/* re-enable segmentation int */
	movl	(sp)+,ap
	clrl	segerr
	movl	(r3),(r3)		/* try writing the location */
	pushl	ap
	movl	$sig_segv,arg1
	moval	hndseg,sgvec
	clrl	sgvec+4
	clrl	sgvec+8
	moval	sgvec,arg2
	movl	$2,argn
	moval	argn,ap
	chmk	$_sigvec		/* re-install old handler */
	movl	(sp)+,ap
	tstl	segerr
	 jeql	hndrn1			/* other segmentation error */
	bsbw	nomem			/* complain */
	ret				/* and done */

.align	2
hndseg1:
	.word	0
	movl	$1,segerr		/* got error we were looking for */
	movl	12(ap),r1
	addl2	$3,12(r1)		/* skip losing instruction */
	movl	12(r1),intpcs		/* new pc, pass back down */
	moval	hndseg2,16(r13)		/* return to our code */
	ret

hndseg2:
	moval	hndseg3,16(r13)		/* keep returning to our code */
	ret
hndseg3:
	addl2	$16,sp			/* clear stuff off sp */
	movl	intpcs,(sp)		/* new PC */
	rei				/* done */

.align	2
hndrnd:	.word	bit0+bit1+bit2+bit3+bit4+bit5
hndrn1:	subl3	$1,4(ap),r2
	mull2	$itesiz,r2		/* offset in inttbl */
	addl2	$inttbl,r2
	movl	itmsg(r2),r1
	movl	itmsl(r2),r3
	movl	(r3),r3
	clrl	r5
	tstl	itfat(r2)
	 jneq	hndfat			/* fatal error, sometimes */
	bsbw	print			/* print the message */
	mcoml	$1,r1
	bsbw	quit
hnddon:	ret				/* done */
hndfat:	ashl	$16,r3,r0
	tstl	ingc
	 jneq	ifatal			/* fatal in GC */
	tstl	ecall
	 jeql	ifatal			/* fatal if no error atom */
	movl	12(ap),r4		/* pick up sigcontext */
	movl	12(r4),intold		/* PC */
	movl	4(ap),intflt		/* interrupt code */
	moval	hndft1,16(r13)		/* return to our code */
	movl	4(r4),intmsk		/* pass old mask back down */
	ret
ifatal:	bsbw	rfatal
	jmp	comper

hndft1:	moval	hndft2,16(r13)		/* clobber next return address */
	ret				/* and return again */

hndft2:	movl	$1,argn
	movl	intmsk,arg1
	pushl	ap
	moval	argn,ap
	chmk	$_sigsetmask
	movl	(sp)+,ap
	addl2	$16,sp
	moval	hndft3,(sp)		/* return from interrupt to our code */
	rei

hndft3:	bsbw	iframe				/* make a frame */
	movl	$t.word,(r13)+
	movl	intold,(r13)+
	movl	$t.word,(r13)+
	movl	intflt,(r13)+
	movl	$2,r0
	movl	ecall,r1
	bsbw	mcallz			/* call error */
1:	clrl	r1
	bsbw	quit			/* what a chomper */
	brb	1b

.align	2
hndstp:	.word	bit1
	tstl	oldtty
	 beql	1f
	pushl	ap
	mcoml	$1,r1
	bsbw	quit
	movl	(sp)+,ap
1:	ret

/****************************************************************
*								*
*								*
*			Record tables				*
*								*
*								*
****************************************************************/
	
/* first, a few definitions */

	.set	ln.any,0
	.set	ln.atom,10
	.set	ln.frame,12
	.set	ln.gbind,10
	.set	ln.lbind,16

/* atom record table */

/* table format:

  # elements,, type
  type,, length				| one entry for each element
  offset in record,, code for set/get	| in the record
*/


atmtbl:	.word	4, ln.atom, t.gbind, ln.gbind, 0, 11, t.bind, ln.lbind
	.word	2, 11, t.str, ln.any, 5, 8, t.obl, ln.atom, 8, 11
	.word	t.typc, 0, 4, 13

frmtbl:	.word	-8, ln.frame, t.msubr, 4, 0, 10, t.fix, 0, 2, 6, t.fix
	.word	16, 4, 3, t.fix, 0x912, 4, 3, t.frame, 8, 6, 10
	.word	t.fix, 18, 8, 3, t.bind, 0x812, 8, 3, t.fix, 0, 10, 6

bndtbl:	.word	-6, ln.lbind, t.any, ln.any, 0, 12, t.atom, ln.atom
	.word	4, 11, t.any, ln.any, 6, 12, t.bind, ln.bind, 10, 11
	.word	t.bind, ln.bind, 12, 11, t.fix, 0, 14, 6

gbntbl:	.word	3, ln.gbind, t.any, ln.any, 0, 12, t.atom, ln.atom, 4, 11
	.word	t.any, ln.any, 6, 12


/****************************************************************
*								*
*								*
*			Boot loader				*
*								*
*								*
****************************************************************/

.set	gcbase,sysbot-2000
.set	gcs_addr, (((gcbase-byts_page+1)/byts_page)+1)*byts_page
.set	lgcs_addr, gcs_addr-gcsizb
.set	gcs_pg, gcs_addr/byts_page
.set	lgcs_pg, lgcs_addr/byts_page

strlen:	movl	(r8),r1
	 jeql	stlndn
1:	incl	r7
	tstb	(r1)
	 jeql	stlndn
	incl	r1
	brb	1b
stlndn:	rsb

booter:	movl	(sp),r6
	clrl	r7
	moval	4(sp),r8
barglp:	bsbw	strlen			/* add len to r7 */
	addl2	$4,r8			/* advance pointer */
	sobgtr	r6,barglp
	clrl	r9
	addl2	$4,r8			/* move past 0 word */
benvlp:	tstl	(r8)
	 beql	bblt			/* all done */
	bsbw	strlen
	addl2	$4,r8
	acbl	$1024,$1,r9,benvlp	/* loop back */
bblt:	addl2	$4,r9
	addl2	(sp),r9			/* # of words needed for ptrs and 0s */
	ashl	$2,r9,r9		/* --> bytes */
	addl2	$3,r7
	bicl2	$3,r7			/* actual number of bytes for strings */
	addl2	r7,r9			/* total bytes needed */
	subl3	r9,$sysbot,r8		/* new top of stack */
	movc3	r9,(sp),(r8)		/* move everything */
	subl3	sp,r8,r9		/* get pointer update into r9 */
	movl	r8,sp
	moval	4(sp),r7
	movl	(sp),r8
bargup:	tstl	(r7)
	 beql	bargud
	addl2	r9,(r7)
	addl2	$4,r7
	sobgtr	r8,bargup		/* loop for rest of args */
bargud:	addl2	$4,r7
benvup:	tstl	(r7)
	 beql	benvud
	addl2	r9,(r7)
	addl2	$4,r7
	brb	benvup
benvud:	movl	(sp),numarg
	moval	4(sp),argbeg		/* save arg stuff */
	ashl	$2,(sp),r0
	addl2	argbeg,r0
	moval	4(r0),envbeg		/* beginning of environment vector? */
	tstl	(sp)			/* check # args */
	 jneq	newarg			/* some */
	brw	noargs
newarg:	movl	4(sp),r0		/* pick up first arg */
	clrl	r1
	cmpb	(r0),$32		/* file descriptor */
	 bgeq	cloop
	movl	(r0),filnam		/* pick it up */
	subl3	$1,(sp)+,(sp)		/* flush first arg */
	brw	noargs
cloop:	tstb	(r0)
	 jeql	2f
	incl	r0
	incl	r1
	brb	cloop
2:	pushl	r1			/* length of arg string */
	matchc	mudsnl,mudsnm,(sp),*8(sp)
	 jeql	mudsub
	matchc	muds1l,mudsn1,(sp),*8(sp)
	 jneq	noarg1			/* go to noarg1 when not mudsub */
mudsub:	movl	(sp)+,r1
	cmpl	(sp),$1
	 bleq	noargs			/* no args to mudsub */
	mcoml	$1,noboot
	movl	4(sp),argone
	subl3	$1,(sp)+,(sp)		/* flush first arg */
	movl	(sp),numarg
	moval	4(sp),argbeg
	movl	4(sp),r0
	clrl	r1
9:	tstb	(r0)+
	 jeql	8f
	aobleq	$1024,r1,9b
8:	pushl	r1
	locc	$46,(sp),*8(sp)		/* look for dot in name */
	 jeql	3f			/* not found */
	movl	8(sp),filnam		/* yes, no need to default */
	brw	noarg1
3:	movc3	(sp),*8(sp),savf	/* copy the first part */
	movc3	$5,svname,(r3)		/* copy .save */
	clrb	(r3)			/* make sure asciz */
	moval	savf,filnam		/* save pointer away */
noarg1:	movl	(sp)+,r1
	
					/* initialize assorted things */
noargs:	movl	$lgcs_addr,gcsmin	/* leave 2000 words for system stack */
					/* (empirically, sp is left */
					/* at approximately 0x7fffee2c) */
	clrl	intflg			/* clear the intflg at startup */
	clrl	spsto			/* make sure spsto starts null */
	movl	tpstart,stkbot		/* put it where user code can see it */
	movl	tptop,stkmax
/*	subl3	$02000,sp,gcsmin	*/
	movl	gcsmin,gcstop
	addl3	$gcsizb,gcsmin,gcsmax	/* no limit for now */

/* make max size of stack area infinite */

setstk:	
	movl	$rlimit_data,arg1
	moval	limits,arg2
	movl	$2,argn
	movl	$argn,ap
	chmk	$_getrlimit
	movl	limits+4,tpmax
	movl	$rlimit_stack,arg1
	moval	limits,arg2
	movl	$2,argn			/* 2 args to vlimit */
	movl	$argn,ap
	chmk	$_getrlimit
	movl	limits+4,p1lim
	brw	cnstrt

/* first check to see if save file exists */

cnstrt:	movl	filnam,r1		/* setup args for open */
	cmpl	r1,$100			/* too small to be string pointer? */
	 blss	1f
	pushl	ap
	moval	argn,ap
	movl	$2,argn
	movl	r1,arg1
	clrl	arg2
	chmk	$_open			/* can't call openz 'cause */
	movl	(sp)+,ap		/* don't have memory yet */
	 jcs	nosave
	movl	r0,r1
1:	pushl	ap
	moval	argn,ap
	clrl	arg3
	movl	$3,argn
	clrl	sgvec+4
	clrl	sgvec+8
	moval	sgvec,arg2
	movl	$sig_cont,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec		/* enable continue */
	movl	$sig_ttou,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec
	movl	$sig_int,arg1		/* enable for some fatal interrupts */
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_quit,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_ill,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_fpe,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_bus,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_segv,arg1
	moval	hndseg,sgvec
	chmk	$_sigvec
	movl	$sig_alrm,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec		/* alarm-clock */
	movl	$sig_sys,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_chld,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec		/* inferior interrupts */
	movl	$sig_urg,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec
	movl	$sig_io,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec
	movl	$sig_pipe,arg1
	moval	hndlr,sgvec
	chmk	$_sigvec
	movl	$sig_tstp,arg1
	moval	hndstp,sgvec
	chmk	$_sigvec
	movl	$sig_xcpu,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	movl	$sig_xfsz,arg1
	moval	hndrnd,sgvec
	chmk	$_sigvec
	bsbw	irestor
	clrl	r0			/* no args */
	movl	-(r13),r1
	bsbw	mcall
	bsbw	die

/* here to enable signals */

iatic:	pushl	ap
	pushl	r1
	movl	$sig_int,arg1		/* lets set up signals */
	cmpb	$1,r1			/* is it control-A */
	 jneq	1f
	movl	$sig_quit,arg1
1:	moval	hndlr,sgvec
	clrq	sgvec+4
	movl	$3,argn
	clrl	arg3
	moval	sgvec,arg2
	moval	argn,ap
	chmk	$_sigvec
	 bcs	sigdie
	movl	(sp)+,r1
	movl	(sp)+,ap
	movl	$t.fix,r0
	rsb

sigdie:	movl	$siglos,r1
	movl	lsiglo,r3
	clrl	r5
	bsbw	print
	bsbw	die

/* initialize random variables */

nosave:	tstl	noboot
	 jeql	1f
	moval	nofile,r1
	movl	nofill,r0
	ashl	$16,r0,r0
	bsbw	efatal
1:	pushl	ap
	movl	$2,argn
	movl	$rlimit_stack,arg1
	moval 	limits,arg2
	movl	p1lim,limits
	movl	p1lim,limits+4
	chmk	$_setrlimit	/* get all you can */
	moval	prstart,r1	/* beginning of pure area */
	addl2	$pur_init,r1	/* initial size of pure area */
	movl	r1,tpstart	/* beginning of stack */
	movl	r1,r13		/* stack pointer */
	addl3	$tp_size,r1,tptop	/* top of stack before buffer */
	pushl	ap
	movl	$1,argn
	movl	tptop,arg1
	moval	argn,ap
	chmk	$_break			/* get space for stack */
	movl	(sp)+,ap
	movl	$boomsg,r1
	movl	lbooms,r3
	clrl	r5
	bsbw	print
	movl	$boobuf,r1
	movl	$4,r3
	clrl	r5
	clrl	boobuf
	bsbw	read
	movzbl	boobuf,r1
	cmpb	r1,$'-
	 jeql	bmone
	cmpb	r1,$'0
	 jneq	bone
	clrl	bootyp
	jmp	doboot
bmone:	mcoml	$0,bootyp
	jmp	doboot
bone:	movl	$1,bootyp
doboot:	clrl	mdepth			/* no nesting yet on mcalls */
	clrl	mtrace			/* non-zero means trace mcalls */

/*	** initialize page table **	*/

	movl	$0x40000000/byts_page,p0tbl	/* all of p0 space for now */
	clrl	p0tbl+4		/* starts at 0 */
	mcoml	$0,p0tbl+8		/* neg val means unusable */
	movl	$(lgcs_addr-0x40000000)/byts_page,p1tbl  /* most of p1 */
	movl	$0x40000000/byts_page,p1tbl+4
	clrl	p1tbl+8
	movl	$(gcs_pg-lgcs_pg),gctbl
	movl	$lgcs_pg,gctbl+4
	movl	$1,gctbl+8		/* zone 1 has gc space */
	movl	$(0x7fffffff-gcs_addr)/byts_page,stktbl
	movl	$gcs_addr/byts_page,stktbl+4
        mcoml	$0,stktbl+8
	clrl	endtbl
			
/* initialize record table */

	movl	$t.frame,r0
	movl	$frmtbl,r1
	bsbw	brectb
	movl	$t.bind,r0
	movl	$bndtbl,r1
	bsbw	brectb
	movl	$t.atom,r0
	movl	$atmtbl,r1
	bsbw	brectb
	movl	$t.obl,r0
	movl	$atmtbl,r1
	bsbw	brectb
	movl	$t.gbind,r0
	movl	$gbntbl,r1
	bsbw	brectb
	movl	$t.lval,r0
	movl	$atmtbl,r1
	bsbw	brectb
	movl	$t.gval,r0
	movl	$atmtbl,r1
	bsbw	brectb
	movl	$t.link,r0
	movl	$atmtbl,r1
	bsbw	brectb

/* build atom hash table */

	movl	$lhsize,r0		/* allocate space */
	bsbw	iblock			/* for hash table */
	movl	r6,topobl+4		/* store in known place */
	movl	$hsize<16+t.vec,topobl	/* > size and type of table */
	movl	$lhsize<16+t.vec+dope,hsize*8(r6) /* dope vector for tobl */

/* make each bucket be a list */

	movl	$hsize,r0		/* number of buckets */
	movl	$t.list,r1		/* list type */
1:	movl	r1,(r6)			/* load type word */
	addl2	$8,r6			/* step through hash table */
	sobgtr	r0,1b			/* loop until done */

/* open a channel to boot file */

	clrl	bsendf			/* not eof */
	movl	lbootf-2,r0		/* setup length */
	movl	$bootf,r1		/* address of name */
	clrl	r3			/* mode 0 is read only */
	bsbw	open			/* open the file */
	cmpl	r0,$t.false		/* failed? */
	 jneq	1f
godie:	  bsbw	die
1:	movl	r1,bschan		/* save boot channel */
	movl	$dum4,r11		/* point to dummy msubr vect */

bloop:	bsbw	bsread			/* read an object */
	tstb	bsendf			/* EOF? */
	 jeql	bloop			/* no, keep trying */

	movl	bschan,r1		/* arg for close */
	bsbw	close			/* close the channel */

	movl	$s.boot,r6		/* get address of BOOT atom name */
	bsbw	bslkp			/* search */
	tstl	r0			/* found boot atom? */
	 jeql	godie			/* nope */

/* enter MDL environment (after all, that's what a bootstrap does) */

	pushl	r6			/* save boot atom pointer */
	bsbw	iframe			/* make a frame */
	movl	r13,r12			/* setup frame pointer */
	movl	$dummy,fr.msa(r12)	/* bs dummy frame */
	bsbw	iframe			/* another frame */

/* proclaim winnage */

	movl	$ldmsg,r1		/* message address */
	movl	lldmsg,r3		/* it's length */
	clrl	r5			/* this means tty */
	bsbw	print			/* print it */

	movl	(sp)+,r1		/* get back boot atom */
	movl	$1,r0			/* No arguments */
	movl	$dum4,r11		/* setup a dummy msubr */
	movl	$t.fix,(r13)+
	movl	bootyp,(r13)+
	bsbw	mcall			/* do the call */

/* should return pointer to routine to call in r1 */

	movl	r1,(r13)+		/* save pointer to routine */

/* before actually calling it, lets try to save this crud */

	movl	filnam,r1		/* pointer to name */
	movl	$1,r3			/* open for output */
	bsbw	openz			/* try to open file */
	cmpw	r0,$t.false		/* failure? */
	 jneq	1f			/* no, try to write */

	movl	$savlos,r1		/* say save loss */
	movl	lsavlos,r3
	clrl	r5
	bsbw	print
	bsbw	die			/* die in this case */

1:	clrl	r0			/* Nothing fancy on return PC */
	clrl	r2			/* no extra zones yet */
	clrl	r3
	bsbw	dosave

/* now get back routine to call etc */

	movl	-(r13),r1		/* and get back pointer to routine */
	clrl	r0
	bsbw	mcall			/* try to call it (ha ha ha) */
	bsbw	die			/* not yet implemented */
	

/* utility subroutines for booting */

/* brectb - add record table
* call:
*	r0/ type
*	r1/ record table address	*/

brectb:	ashl	$-6,r0,r0	/* isolate type */
	bicl2	$0xFFFFFFC0,r0	/* 6 bits */
	ashl	$3,r0,r0	/* make table index */
	movl	r1,rectbl+4(r0)	/* store address */
	movl	$t.fix,rectbl(r0) /* legal type */
	rsb

/* bin - read a byte 
* call:
*	bsbw	bin
* return:
*	r0/ byte read
*	bsendf/ -1 if EOF read	*/

bin:	movl	$3,argn		/* setup for call */
	movl	bschan,arg1	/* boot channel */
	movl	$bsinch,arg2	/* where to read to */
	movl	$1,arg3		/* just one byte */
	pushl	ap		/* save linkage */
	movl	$argn,ap	/* setup linkage for sys call */
	chmk	$_read		/* read in */
	movl	(sp)+,ap	/* restore linkage */
	tstl	r0		/* any errors? */
	 jlss	bsioer		/* yes, die */
	 jneq	1f		/* EOF? */
	movb	$0xFF,bsendf	/* yes, flag it */
1:	movl	bsinch,r0	/* store byte read */
	rsb

/* bsread - read an object from boot file
* call:
*	bsbw	bsread
* return:
*	(eof read)	*/

bsread:	tstb	bsendf		/* EOF yet? */
	jeql	1f		/* no, keep reading */
	 rsb			/*  yes, return */
1:	movzbl	bsbrk,r0	/* already a break character? */
	 jneq	2f		/* no */
	bsbw	bin		/* bin a byte */
2:	clrb	bsbrk		/* not a break character, we assume */
	cmpb	r0,$'|		/* vbar? */
	 jeql	bscod		/* read code */
	cmpb	r0,$'#		/* sharp? */
	 jeql	bstyp		/* type */
	cmpb	r0,$'[		/* ] bracket? */
	 jeql	bsvec		/* vector */
	cmpb	r0,$'(		/* ) open paren? */
	 jeql	bslst		/* list */
	cmpb	r0,$'"		/* " dbl-quote? */
	 jeql	bsstr		/* string ( */
	cmpb	r0,$')		/* right paren? */
	 jeql	retunb		/* oops [ */
	cmpb	r0,$']		/* right bracket? */
	 jneq	chexc		/* no, try for excl */
retunb:	movl	r0,r6		/* return bad character */
	movl	$t.unb,r0
	rsb

chexc:	cmpb	r0,$'!		/* excl? */
	 jeql	bschar		/* character */
	bsbw	bssep		/* seperator? */
	 jeql	bsread		/* yes, keep reading */
	cmpb	r0,$'0		/* is it a number? */
	 jlss	bsatm		/* not if less than 0 */
	cmpb	r0,$'9		/* or */
	 jgtr	bsatm		/* greater than 9 */
				/* drop through to read fix */
bsfix:	clrl	r1		/* indicates fix/ float */
	subl3	$'0,r0,r2	/* accumulate in r2 */
	clrl	r4		/* no fractional part yet */
	movl	$1,r4		/* number of digits read */
bsfixl:	bsbw	bin		/* read next byte */
	bsbw	bssep		/* seperator? */
	jeql	bsfixe		/* yes, tie it off */
	tstl	r1		/* reading fraction? */
	jneq	bsfix2		/* yes, go read it */
	cmpb	r0,$'.		/* is it a dot? */
	 jneq	1f		/* no, add to fix */
	  movl	$1,r1		/*  start fractoin */
	  brb	bsfixl		/*  and continue */
1:	mull2	$10,r2		/* multiply sum */
	subl2	$'0,r0		/* make numeric */
	addl2	r0,r2		/* accumulate */
	brb	bsfixl		/* and continue */

bsfix2:	mull2	$10,r3		/* multiply fraction */
	subl2	$'0,r0		/* accumulate */
	addl2	r0,r3
	mull2	$10,r1		/* and step fractional mantissa */
	brb	bsfixl		/* and continue */

bsfixe:	movb	r0,bsbrk	/* remember terminating byte */
	tstl	r1		/* are we floating? */
	 jneq	bsflt		/*  yes */
	movl	r2,r6		/* no, fix value here */
	movl	$t.fix,r0	/* type */
	rsb

bsflt:	bsbw	die		/* haven't decided this yet... */

	movl	$t.float,r0	/* but eventually, */
	rsb			/* return a float */

/* here to read # format type */

	.set	pnam, 8

bstyp:	bsbw	bsread		/* recurse to read atom */
	movl	pnam+4(r6),r7	/* pname **** depends on format ***** */
	movl	(r7),r0		/* get first 4 characters */
	movl	$t.msubr,r1	/* guess at msubr */
	cmpl	r0,s.msub	/* right? */
	 jeql	1f		/* yes */
	movl	$t.imsub,r1
	cmpl	r0,s.imsub
	 jeql	1f
	movl	$t.decl,r1
	cmpl	r0,s.decl
	 jeql	1f
	movl	$t.unb,r1
	cmpl	r0,s.unbo
	 jeql	1f
	movl	$t.false,r1
	cmpl	r0,s.fals
	 jeql	1f
	bsbw	die		/* none of the above, we lose */
1:	movw	r1,-(sp)	/* push type */
	bsbw	bsread		/* read next item */
	movw	(sp)+,r0	/* restore type */
	cmpw	$t.msubr,r0	/* is it msubr? */
	 jeql	bsty_sg		/* yes, do SETG */
	cmpw	$t.imsub,r0	/* or imsubr */
	 jeql	bsty_sg		/* ditto */
	rsb

	.set	msb.name, 12
	.set	gb.atm, 0

bsty_sg: movl	msb.name(r6),r8	/* r8 is the atom now */
	movl	gb.atm(r8),r8	/* gbind now */
	movl	r0,ot(r8)	/* save type */
	movl	r6,ov(r8)	/* and value */
	rsb

/* here to read a character */

bschar:	bsbw	bin		/* read the backslash */
	cmpb	$'/,r0		/* is it? */
	 jneq	die		/* oh no */
	bsbw	bin		/* now read char */
	movl	t.char,r0	/* but throw it away? */
	rsb

/* read a string */

bsstr:	clrl	r1		/* r1 will count charcters */
	clrb	r2		/* indicates \ seen */
bsstrl:	bsbw	bin		/* read */
	tstb	r2		/* quoted? */
	 jneq	bsinstr		/* yes, it stays */
	cmpb	r0,$'\		/* is this the quote character? */
	 jneq	1f		/* naw */
	incb	r2		/* yes, flag we saw one */
	brb	bsstrl		/* and read next */
1:	cmpb	r0,$'"		/* " end of string? */
	 jeql	bsmaks		/* yes, make it a real string */
bsinstr: movl	$t.char,(r13)+
	movl	r0,(r13)+	/* push the byte */
	incl	r1		/* count chars */
	clrb	r2		/* not quoted anymore */
	brb	bsstrl		/* and keep reading */

/* here to actually make a string */

bsmaks:	movl	$t.str,r0	/* string type */
	bsbw	ublock		/* make a string */
	movl	r1,r6		/* return pointer where we need it */
	rsb			/* and return */

/* read an atom */

bsatm:	clrl	r1		/* prepare count of characters */
	brb	bsatm1		/* and push first character */

bsatml:	bsbw	bin		/* read next */
	cmpb	r0,$'\		/* quote character? */
	 jneq	1f		/* no */
	 bsbw	bin		/* yes, read next character */
	 bsbw	bsatm1		/* and push it */
1:	bsbw	bssep		/* separator? */
	 jeql	bsatm3		/* yes... */
bsatm1:	movl	$t.char,(r13)+
	movl	r0,(r13)+	/* push chars on TP stack */
	incl	r1		/* and count them */
	brb	bsatml		/* keep reading */

bsatm3:	movb	r0,bsbrk	/* save break character */
	movl	$t.str,r0	/* we want to make a string */
	bsbw	ublock		/* out of the atom name on TP stack */

	pushl	(r1)		/* save word of chars */
	movq	r0,-(sp)	/* save string */
	bsbw	bslkp		/* lookup the atom */
	tstl	r6		/* was there one? */
	 jeql	1f		/* no, add it */
 
	addl2	$12,sp		/* remove string */
	rsb			/* if exists, return it */

/* push gbind, lbind, pname, obl onto TP stack, then call record: */

1:	movl	$t.unb,(r13)+	/* make an unbound gbind */
	clrl	(r13)+
	clrl	(r13)+
	clrl	(r13)+
	clrl	(r13)+
	clrl	(r13)+
	movl	$t.gbind,r0	/* type */
	movl	$3,r1		/* number of elements */
	bsbw	record		/* build a gbind */
	movl	r0,(r13)+	/* push gbind */
	movl	r1,(r13)+	/* rest of gbind (value) */
	movl	$t.fix,(r13)+	/* lbind */
	clrl	(r13)+		/* to stack */
	movq	(sp)+,(r13)+	/* zap it onto tp stack */
	movl	$t.atom,r0
	movl	$3,r1		/* 4 elements */
	bsbw	record		/* build an atom */
	movl	r1,r6		/* return pointer where it belongs */
	movl	bsaptr,r2	/* put in table */
	movl	(sp)+,(r2)+	/* name */
	movl	r6,(r2)+	/* atom */
	movl	r2,bsaptr	/* update table pointer */
	rsb

/* lookup atom in boot table */

bslkp:	movl	(r6),r0		/* name to r0 */
	moval	bsatbl,r7	/* pointer to table */
bslkpl:	movl	(r7),r1		/* get name */
	bneq	1f		/* branch if not done yet */
	 clrl	r6		/* done, return not found */
	 rsb
1:	cmpl	r0,r1		/* is it this one? */
	bneq	2f		/* nope, loop */
	movl	4(r7),r6	/* GOT IT - return atom pointer */
	movl	$t.atom,r0	/* type atom if we care */
	rsb
2:	addl2	$8,r7		/* next entry */
	brb	bslkpl		/* and loop */
	

/* read code */
bsfoo:	brb	bscodl
bscod:	clrl	r1		/* count */
bscodl:	bsbw	bin		/* read a byte */
	cmpb	r0,$'|		/* vbar? */
	 jeql	bscod2		/* yes, end */
	cmpb	r0,$'0		/* is it between 0 */
	 jlss	bsfoo
	 jlss	bscodl		/* and 9? */
	cmpb	r0,$'9		/* maybe... */
	 jleq	bscod1		/* yes, ok */
	cmpb	r0,$'A		/* how abouf A-F? */
	 jlss	die
	cmpb	r0,$'F
	 jgtr	die		/* no, die */
	subl2	$'A-'0-10,r0	/* normalize */
bscod1:	subl2	$'0,r0		/* make it a byte */
	movb	r0,(r13)+	/* push it */
	incl	r1		/* keep counting */
	brb	bscodl		/* and loop */

bscod2:	ashl	$-1,r1,r1	/* number of bytes */
	movl	r1,r0		/* make spare copy */
	movl	r1,r9		/* save another copy */
	addl2	$11,r0		/* to words */
	ashl	$-2,r0,r0	/* round it */
	bsbw	iblock		/* allocate */
	movl	r9,r1		/* restore number of bytes */
	ashl	$14,r1,r0	/* count to left half (lwords) */
	movw	$t.mcode,r0	/* type in right */
	addl3	r6,r1,r7	/* point to dope words */
	movl	r7,r10		/* make a spare copy */
bsclp:	movb	-(r13),r2	/* get a nibble from stack */
	movb	-(r13),r3	/* and another one */
	ashl	$4,r3,r3	/* shift left */
	bisb2	r2,r3		/* two nibbles / byte */
	movb	r3,-(r7)	/* put the code where it belongs */
	sobgtr	r1,bsclp	/* and loop for all bytes */

	addl3	$3,r10,r1	/* round to long word */
	bicb2	$3,r1		/* make long address */
	movl	r1,r7		/* copy */
	addl2	$11,r9		/* round bytes to lword, plus dope */
	ashl	$14,r9,r9	/* shift to left half */
	movw	$dope+t.msubr,r9 /* set type in right half */
	movl	r9,(r7)		/* dope word */
	rsb

/* read a vector */

bsvec:	clrl	r1		/* count of elements */
bsvecl:	pushl	r1		/* save count */
	bsbw	bsread		/* read an element */
	movl	(sp)+,r1		/* restore count */
	cmpw	$t.unb,r0
	 jneq	bsvecx
	cmpw	$'],r6		/* end of vector? */
	 jeql	bsvec2		/* yes */
bsvecx:	movl	r0,(r13)+	/* save type */
	movl	r6,(r13)+	/* and value */
	incl	r1		/* ount elements */
	brb	bsvecl		/* and keep reading */

bsvec2:	movl	$t.vec,r0	/* type to r0 */
	bsbw	ublock		/* build the thing */
	movl	r1,r6		/* return pointer in r6 */
	rsb

/* read a list */

bslst:	clrl	r1		/* count */
bslstl:	pushl	r1		/* save count */
	bsbw	bsread		/* read an element */
	movl	(sp)+,r1		/* restore count */
	cmpw	$t.unb,r0
	 jneq	bslstx		/* ( */
	cmpb	$'),r6		/* end of list? */
	 jeql	bslst2		/* yes, ... */
bslstx:	movl	r0,(r13)+	/* push type */
	movl	r6,(r13)+	/* and value */
	incl	r1		/* count */
	brb	bslstl		/* and looop */

bslst2:	bsbw	blist		/* build a list */
	movl	r1,r6		/* save pointer */
	rsb


/* check if character in r0 is a separator 
* call:
*	r0/ character
* return:
*	Z condition set if separator
*	(preserves all registers)	*/

bssep:	cmpb	r0,$'"		/* quote? */
	 jeql	1f		/* yes */
	cmpb	r0,$')
	 jeql	1f
	cmpb	r0,$']
	 jeql	1f
	cmpb	r0,$040		/* space */
	 jeql	1f
	cmpb	r0,$012		/* lf */
	 jeql	1f
	cmpb	r0,$015		/* cr */
	 jeql	1f
	cmpb	r0,$014		/* ff */
	 jeql	1f
	cmpb	r0,$26		/* ^Z */
	 jeql	2f		/* is eof */
	tstb	r0		/* as is */
	 jeql	2f		/* nul */
	rsb			/* return NEQL (cuz r0 isn't 0) */

2:	movb	$1,bsendf	/* flag eof */
1:	tstb	$0		/* be sure EQL (Z set) */
	rsb

/* death and destruxtion */

/* calngs -- come from mcall to here if thing being mcalled is not an atom

	r0/	# args
	r1/	atom pointer
	r2/	pc where mcall happened (relative)
*/

calngs:	tstl	ncall		/* is there an ncall atom? */
	 jeql	ngsdie		/* no, die */
	
	movl	r13,r3		/* copy TP stack pointer */
	addl2	$8,r13		/* room for atom to call with */
	movl	r0,r4		/* copy arg count */
	jeql	1f

2:	movq	-(r3),8(r3)	/* cute (I think) */
	sobgtr	r4,2b

1:	movl	$ln.atom<16+t.atom,(r3)	/* make it an arg */
	movl	r1,4(r3)
	incl	r0		/* one more arg */
	movl	ncall,r1
	brw	mcallx		/* now do MCALL again*/
	
/* iacall -- here to apply aribtrary thing from user code 

	r0,r1/	thing to apply
	r3/	# of args
*/

iacall:	cmpw	r0,$t.msubr
	 jneq	iacal1		/* not calling an msubr */
	subl3	(sp)+,im.code+ov(r11),r2	/* relative return pc */
	movl	r1,r4		/* msubr into r4 */
	movl	r3,r0		/* number of args to r0 */
	jmp	icret		/* go for it */
iacal1:	tstl	ncall
	 jeql	ngsdie
	movl	r13,r5
	addl2	$8,r13		/* room on tp stack */
	movl	r3,r4		/* copy count */
	jeql	1f

2:	movq	-(r5),8(r5)
	sobgtr	r3,2b

1:	movq	r0,(r5)
	movl	ncall,r1
	addl3	$1,r4,r0
	brw	mcall

discom:	movl	$dismsg,r1	/* message */
	movl	ldisms,r3	/* length */
	brw	msgdie

ugverr:	subl3	(sp),im.code+ov(r11),(sp)	/* relative return pc */
	movl	ecall,r1
	 jneq	1f
noeicc:	movl	$commsg,r1
	movl	lcomms,r3
	brw	msgdie
1:	bsbw	iframe		/* make frame */
	movl	$1,r0		/* one argument */
	movl	4(sp),r2
	cmpw	-4(r2),$t.atom	/* did we get atom instead of gbind? */
	 jneq	2f
	movl	$(a.len<17+t.gval),(r13)+
	movl	(r2),(r13)+
	brb	3f 
2:	movq	-4(r2),(r13)+	/* push it */
3:	bsbw	mcallz
	subl3	(sp)+,im.code+ov(r11),(sp)	/* flush argument */
	rsb			/* return */

cmperr:
comper:	movl	ecall,r1	/* does error atom exist... */
	 jneq	1f
	movl	$commsg,r1	/* get message */
	movl	lcomms,r3	/* length */
	brb	msgdie		/* say it and die */

1:	tstl	ingc
	 jeql	2f
	moval	gcerr,r1	/* don't call error in GC */
	movl	lgcerr,r3
	brb	msgdie
2:  	bsbw	iframe		/* create frame for call to error */
	clrl	r0		/* no args to error in compiled code */
	brw	mcall

unimpl:	movl	$unimsg,r1
	movl	lunims,r3
	brb	msgdie

bsioer:	movl	$biomsg,r1
	movl	lbioms,r3
	bsbw	die

illdis:	movl	$illmsg,r1	/* illegal dispatch address specified */
	movl	lillms,r3
	brb	msgdie

ngsdie:	movl	$ngsmsg,r1
	movl	lngsms,r3
	brb	msgdie

die:	movl	$diemsg,r1
	movl	ldiems,r3
	brb	msgdie

msgdie:	clrl	r5		/* clear channel means tty */
	bsbw	print		/* print message */
jstdie:	mcoml	$1,r1
	bsbw	quit
	jmp	comper

/* storage */
	.data

/* fun things */

spaces:	.ascii	"    "			/* 4 spaces */
lesst:	.ascii	"<"
gtrt:	.ascii	">"
crlf:	.byte	015			/* CR */
	.byte	012			/* LF */

ldmsg:	.ascii "MimiVAX loaded
"
lldmsg:	.long	lldmsg-ldmsg

bootf:	.ascii "boot.msubr"
lbootf: .long	lbootf-bootf

intmsg:	.ascii	"Interrupt character typed"
intmsl:	.long	intmsl-intmsg
qutmsg:	.ascii	"Quit character typed"
qutmsl:	.long	qutmsl-qutmsg
ilomsg:	.ascii	"Illegal instruction"
ilomsl:	.long	ilomsl-ilomsg
fpemsg:	.ascii	"Floating point exception"
fpemsl:	.long	fpemsl-fpemsg
busmsg:	.ascii	"Bus error"
busmsl:	.long	busmsl-busmsg
segmsg:	.ascii	"Segmentation error"
segmsl:	.long	segmsl-segmsg
sysmsg:	.ascii	"Bad arg to system call"
sysmsl:	.long	sysmsl-sysmsg

cpumsg:	.ascii	"CPU time limit exceeded"
cpumsl:	.long	cpumsl-cpumsg
fszmsg:	.ascii	"File size limit exceeded"
fszmsl:	.long	fszmsl-fszmsg

fatmsg:	.ascii 	"Fatal error -- "
fatmsl:	.long	fatmsl-fatmsg

dismsg:	.ascii "Dispatch compiler error"
ldisms:	.long	ldisms-dismsg

commsg:	.ascii "Comper death"
lcomms:	.long	lcomms-commsg

gcerr:	.ascii	"Error in GC"
lgcerr:	.long	lgcerr-gcerr

cgmsg1:	.ascii	"GC running--please wait..."
cgmsgl:	.long	cgmsgl-cgmsg1

cgmsg2:	.ascii	"GC done.
"
cgms2l:	.long	cgms2l-cgmsg2

biomsg:	.ascii	"IO error reading bootstrap"
lbioms:	.long	lbioms-biomsg

illmsg:	.ascii "Illegal dispatch entry encountered"
lillms:	.long	lillms-illmsg

siglos:	.ascii	"Error from signal set"
lsiglo:	.long	lsiglo-siglos

intlos:	.ascii	"No interrupt handler yet"
lintlos:	.long	lintlos-intlos

diemsg:	.ascii "Die death"
ldiems:	.long	ldiems-diemsg

ngsmsg:	.ascii "Calngs death"
lngsms:	.long	lngsms-ngsmsg

unimsg:	.ascii "Unimplemented death"
lunims:	.long	lunims-unimsg

boomsg:	.ascii "How to boot (1 big, 0 mbins, -1 msubrs):  "
lbooms:	.long	lbooms-boomsg

mudsnm:	.ascii	"mudsub"
mudsnl:	.long	6
mudsn1:	.ascii	"MUDSUB"
muds1l:	.long	6
period:	.ascii	"."
svname:	.ascii	".save"

newker:	.ascii	"Loading kernel to match save file version
"
newkln:	.long	newkln-newker
savver:	.ascii	"Save file uses wrong kernel version"
savvel:	.long	savvel-savver

nofile:	.ascii	"Save file not found"
nofill:	.long	nofill-nofile

/* chmks that can be interrupted out of */
intcmk:	.long	_wait
	.long	_sigpause
	.long	_read
	.long	_readv
	.long	_write
	.long	_writev
	.long	_ioctl
	.long	_connect
	.long	_select
	.long	_send
	.long	_recv
	.long	_recvmsg
	.long	_sendmsg
	.long	_sendto
	.long	_recvfrom
intcml:	.long	(intcml-intcmk)/4

/* interrupts that muddle knows how to handle */
intb1:	.byte	sig_int
	.byte	sig_chld
	.byte	sig_quit
	.byte	sig_cont
	.byte	sig_pipe
	.byte	sig_urg
	.byte	sig_io
	.byte	sig_segv	/* only set when we get a stack overflow */
intlen:	.long	intlen-intb1

/* translation of interrupt for muddle system (reverse order of previous
   table) */
intb2:	.byte	0	/* never used */
	.byte	31
	.byte	32
	.byte	33
	.byte	34
	.byte	35
	.byte	1
	.byte	19
	.byte	7

kernam:	.ascii	"/usr/mim/xmdl."
verptr:	.space	10		/* will be clobbered at appropriate time */
homstr:	.ascii	"/USR"
hextr:	.byte	0
	.set	homlen, 4
	.space	15
savf:	.ascii	"mim.saved"
extr:	.byte	0		/* null-termminated */
	.set	savlen, extr-savf
	.space	40-savlen
filnam:	.long	savf		/* pointer to save file name */
noboot:	.long	0		/* set if running as mudsub */

stklos:	.ascii	"Stack overflow"
stklol:	.long	stklol-stklos

restlos:
	.ascii	"Ran out of virtual pages"
restlol:	.long	restlol-restlos

savlos:	.ascii	"Save failed"
lsavlos:	.long	lsavlos-savlos

/* boot string definitions */

s.msub:	.ascii "MSUB"
s.imsub: .ascii "IMSU"
s.decl:	.ascii "DECL"
s.unbo:	.ascii "UNBO"
s.fals: .ascii "FALS"
s.boot: .ascii "BOOT"

bootyp:	.long	0		/* flag for boot */

boobuf:	.long	0

interr:	.long	0
intval:	.long	0
lstcal:	.long	0
lstarg:	.long	0

segerr:	.long	0

argn:	.long	0		/* sys call interface block */
arg1:	.long	1
arg2:	.long	1
arg3:	.long	1

intflt:	.long	0
intold:	.long	0
intpcs:	.long	0
intgpc:	.long	0		/* saved pc for use by control-G code */
intmsk:	.long	0

ruse:
utime:	.long	0		/* block for rntime call */
	.long	0
stime:	.long	0
	.long	0
	.space	56

bschan:	.long	0		/* bootstrap channel */
bsbrk:	.long	0		/* break character to reread for boot */
bsendf:	.long	0		/* bs eof flag */
bsinch:	.long	0		/* character input buffer for boot */

dummy:	.long	0		/* dummy initial frame */
	.long	dum2
	.space	6
dum2:	.long	dum3
dum3:	.long	0
	.long	dum4
dum4:	.long	0
	.long	0

	.set	bsatlnt, 400
bsatbl:	.space	4*bsatlnt
bsaptr:	.long	bsatbl

oldtty:	.space	7*4
newtty:	.space	7*4

argone:	.long	0
numarg:	.long	0
argbeg:	.long	0
envbeg:	.long	0

p1cur:	.long	0
p1lim:	.long	0

stkok:	.long	0			/* set if user has OK'ed growing stack */

cgnois:	.long	0			/* set if ctrl-G during GC */
cgct:	.long	0			/* use to force error when in tight loop */

savstrt: .ascii	"MIMS"			/* used to check save file */
versav:	.long	0
	.set	pagtlen, 256
pagptr:	.word	t.uvec
	.word	pagtlen
pagpt1:	.long	pagtbl			/* address of page table */
pagtbl:					/* 256 longwords */	
p0tbl:	.long	0
	.long	0
	.long	0
p1tbl:	.long	0
	.long	0
	.long	0
gctbl:	.long	0
	.long	0
	.long	0
stktbl:	.long	0
	.long	0
	.long	0
endtbl:	.long	0
	.space	(4*256)-52

minf:	.long	minfv			/* pointer to minf vector */
minfv:	.long	2		/* input stream */
	.long	1		/* output stream */
	.long	32		/* bits/ word */
	.long	8		/* bits/ byte */
	.long	wds_page	/* words/ page */
	.long	4		/* bytes/ word */
	.long	2		/* shift for byte --> word */
	.long	4		/* bytes (not chars)/word */
	.long	4294934527	/* largest possible float */
	.long	4294967295	/* smallest */
minfve:	.set	lminf, minfve-minfv	/* set length of minf vector */
rectbl:	.space	256*2*4		/* 256 types, 2 words each */

type_count: .long t.fretyp	/* free type for user-defined */

ecall:	.long	0
ncall:	.long	0
icall:	.long	0		/* why isn't this defined in MIMIAP? */
uwatm:	.long	0		/* points to unwinder atom */
topobl:	.long	0		/* will be loaded as type vector */
	.long	0		/* will be address of top oblist */
framid:	.long	0		/* global unique frame id */
tbindt:	.long	0		/* type word of top-lev binding chain */
tbind:	.long	0		/* top-level binding chain */
sspsto:	.long	0
sbindid:	.long	0	/* copy of bindid over save/restore */
mtrace:	.long	0		/* non-zero to trace mcalls */
mdepth:	.long	0		/* current depth of mcall trace */
ingc:	.long	0		/* flag saying whether we are in GC */
mapper:	.long	0		/* points to pure-map atom */
runint:	.long	0		/* if non-zero, run interrupts immediately */

sgvec:	.long	0
	.long	0
	.long	0

limits:	.long	0
	.long	0
/* GC storage and definitions */

gcparx:	
rcl:	
gcpar:	.long	0
	.set	rcloff, 0	/* offset from gcparx */
rclvb:	.long	0
	.set	rclvoff, 4	/* offset from gcparx */
rclv1:	.long	0		/* recycle lists for various size blocks */
rclv2:	.long	0
rclv3:	.long	0
rclv4:	.long	0
rclv5:	.long	0
rclv6:	.long	0
rclv7:	.long	0
rclv8:	.long	0
rclv9:	.long	0
rclv10:	.long	0
	.set	max_rcl, 10
gcstop:	.long	0
	.set	gcstopo, gcstop-gcparx
gcsmin:	.long	0
	.set	gcsmino, gcsmin-gcparx
gcsmax:	.long	0
	.set	gcsmaxo, gcsmax-gcparx
	.set	gclnt, ((gcsmaxo+1)/4)+1
czone:	.long	0		/* current zone for GC */

stktop:	.long	0		/* save the top of the stack for save */
tpstart: .long	0		/* pointer to beginning of tp stack */
tptop:	.long	0		/* top of tp stack */
tpmax:	.long	0		/* largest size for data space */
savend:	.long	0
codend:	.align	2		/* this is where MDL stack starts */
				/* put it on a longword boundary */
prstart: .long	0