



		    lisp_.alm                       11/05/86  1612.7r w 11/04/86  1039.0      810711



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
" lisp_.alm	-- evaluator for Multics MACLISP
"
" David Moon, 17 July 1972
" cleaned up and "map" functions added, 1 Aug 72 DAM
" pdl ptr format changed for pdp-10 compatible, 5 Aug 72 DAM
" bug in evaluated functions fixed, 7 Aug 72, DPR
" bug in eval_funarg fixed, 7 Aug 72, DPR
" go, return, eval_list (for prog) added 19 Aug 72, DAM
" call1, callf added 22 Aug 1972 DAM
" nouuo function added 24 Aug 72 DAM
" freturn_real added, meaning of frame.dat1 changed, 24 Jan 73 DAM
" changed to make *rset a variable, 24 May 1973
"
" modified 74.2.07 by DAM to fix bugs in apply of 3 args
" modified 74.04.15 by DAM to make an evalframe for an unbnd vrbl and to ignore
"	macro properties when snapping subr links.
" Modified 74.09.18 by DAM to use the new binding-reversal scheme for funargs and
"  calls to eval or apply with a binding-context-pointer
" Modified 75.03.31 by DAM for evalhook + bug fixes
" Modified 78.09.12 by BSG for "let" fsubr.

"flag bits in x2

	equ	macrobit,1	distinguish macros from fexprs
	equ	exprbit,4		distinguish expr/lexpr from subr/lsubr
	equ	framebit,8	an evalframe was created and must be destroyed
	equ	lsubrbit,16	distinguish lexpr/lsubr from expr/subr
	equ	noteval,32	spread_args should not evaluate args (for apply)
	equ	already_spread,1024	args are already spread, beginning at ap|qsrac+2,x4
	equ	applybit,2	entered by apply rather than eval
	equ	bbf,64		pseudo-binding-block exists because of label or funarg
	equ	fbb,128		flag for a reversal block needed
				" used by eval_funarg
	equ	ignore_macros,256	find_type should ignore macro properties
	equ	went_through_value_cell,512
	equ	already_autoloaded_once,2048
	equ	entered_by_funcall,4096		" to distinguish between funcall and call1

" temporaries on marked pdl

	equ	form,-8		form being evaled.  Inviolable since pdlframe uses it.
				" for apply, is name of fcn being applied
	equ	fcn,-6		function being applied
	equ	argl,-4		argument list. Inviolable since used to construct "form"
				"also handy temporary, contains result of fcn, etc.
					" in case of error during apply
	equ	qsrac,-2		all kinds of random things go here


" temporaries on unmarked pdl

" -2, -1			regular binding block
	equ	pdlptr,-4 a temporary
	equ	svx5u,-4	register save area
	equ	svx2l,-4	..
	equ	svx0u,-3	..
	equ	svx4l,-3	..
	equ	svx3l,-5		since no one uses frame.dat2, save a reg here
	equ	funarg_pdlptr,-7  holds pdl ptr for a funarg
" -6, -5			evalframe goes here
" -8, -7			if a funarg is used, its reversal bb is put here
" -10, -9			random cruft is put here by map, if not map these don't exist

"use of index registers

" x0	calls to recurse,error,...
" x1	scan through stack during binding, random data
" x2	flag bits escribed above)
" x3	number of arguments	
" x4	offset from top of marked pdl to get to above-mentioned temporaries,
		"sometimes random data preserved through a recursion.
" x5	call evalu by tsx5
" x6	random data
" x7	unmarked pdl pointer

"use of base registers

" ab	points to stack header, together with x7 points to unmarked pdl
" ap	points to marked pdl
" bp	random pointer
" bb	temporary
" lp	untouchable
" lb	temporary
" sp	sacred
" sb	sacred


"
"	Use of pdls

" the unmarked pdl contains space for an eval frame (2 words),
" a register save area for recursing and random temps (2 words),
" 2 words for a funarg binding block, 2 words that only exist for map,
" and a binding_block (2 words).  The binding block starts out
" containing no bindings and grows whenever an atom needs to be
" bound.  Since the binding block is created and then added to, the
" same atom may appear more than once and all routines that can unwind
" eval - created binding blocks _m_u_s_t do so from the top down.

" The eval frame is only created in *rset-t mode, but the space for
" it is always allocated since that is easier.  The contents of
" the eval frame are:
"	frame.prev_frame		thread
"	frame.stack_ptr		-> form being evaled (on marked pdl)
"	frame.dat1		rel(sp) at time frame was created.  Low order
"				bit is 1 if this frame is due to apply or map,
"				in which case form is really = fcn, you can cons
"				on argl if you want.
"	frame.dat2		no useful information.  recurse saves x3 here

" the marked  pdl:
"	ap|form			form being evaled or function being applied
"	ap|fcn			functional property of function being applied/evaluated
"	ap|argl			argument list
"	ap|qsrac			temp., holds property lits amung other things

" the above 4 are often referenced with the aid of x4, since the binding block
" is above them on the marked pdl.  x4 contains (almost always) the negative size
" of the binding block (and any other cruft that may be there) so that"ap|form,x4" works.

""" FORMAT OF BINDING BLOCKS

"	Normal Binding Block

"   top_block           bot_block		-> top & bottom of marked pdl cells
"					containing atom,value pairs
"   back_ptr              rev_ptr	--- points at reversal block which reversed this one.
"       A
"    points at previous b.b.


"	Reversal Binding Block  (set up when a binding-context-pointer is used)

"   PDLP                   0			-> lowest b.b. in range, flag for this type
"   back_ptr            rev_ptr		same back_ptr, pointer to reversal
"					block whose range overlaps this one
"					in such a way as to require re-reversing
"					part of the range of this one.
"
" use of "pseudo-binding-blocks"

" a pseudo binding block is a record that at some later time bindings
" are to be made.  labels and funargs create pseudo-binding-blocks
" because they can't do their binding until after the arguments
" have been evaluated, and you can't evaluate the arguments  until
" the real functional property being applied is found.
" a pseudo-binding-block exists on the marked pdl above
" the regular binding block.  It has the same format, except that
" where a binding block would have "saved old value", in the
" pseudo binding block a new value is saved. After the args
" have been evaluated, the pseudo binding block is converted
" into a regular binding block (actually the one just below it
" on the pdl is extended, since they are always contiguous)
" The old value of the atom is put in the binding block, and the
" new-value that was saved in the pseudo binding block is assigned
" to the atomic symbol.
" expr's and lexpr's use variants of the
" pseudo binding block: they can't bind their lambda atoms until
" after the args have been evaluated, since one of the args
" might be a setq, so they just figure out how much pdl space it
" will take to bind their lambda atoms and leave room for
" that before evaluating the args.

"

	include 	lisp_unmkd_pdl
	include	lisp_iochan
	include	lisp_stack_seg
	include	lisp_object_types
	include	lisp_name_codes
"
" entry point for calling eval by pl1 subrs

	entry	eval
eval:	tsx0	pl1_entry-*,ic
	tsx5	evalu-*,ic		enter common code
pl1_return:
	staq	ap|form
	eppap	ap|form+2
pl1_exit:	spriap	lisp_static_vars_$stack_ptr
	stx7	lisp_static_vars_$unmkd_ptr+1
	stc1	ab|in_pl1_code
	short_return

" routine to set up ap, ab, x7 on entry from pl1 code

pl1_entry:
	epbpab	lisp_static_vars_$unmkd_ptr,*
	eppap	lisp_static_vars_$stack_ptr,*
	ldx7	lisp_static_vars_$unmkd_ptr+1
	stz	ab|in_pl1_code
	tra	0,0


" entry point for the lisp lsubr "eval"  Fast call but with lp

	segdef	eval_		  & no prologue

eval_:	cmpx5	-2,du		1 argument?
	tnz	eval_with_2_args-*,ic	no, go do a-list hack.
	tsx5	evalu-*,ic	yes, so enter common code.
lisp_retn:				" deliver us from eval.
	eppap	ap|form
lisp_rtn_1:
	eppbp	ab|-2,x7*
	epplp	ab|-4,x7*
	eax7	-4,x7			(popj)
	tra	bp|0


" Routine called by lisp_prog_fns_ to unwind a reversal bb

	segdef	unwind_reversal

unwind_reversal:
	tsx0	pl1_entry-*,ic
	epplb	lisp_static_vars_$binding_top,*	-> bb to unwind
	tsx3	unwind_reversal_bb-*,ic
	tra	pl1_exit-*,ic
"
" internal entry point for recursive calls to eval (by tsx0)
" on entry object to be evaluated is at ap|-2
" if the object is not a list, its value is immediately found.
"  if it is a list, registers are saved on the unmkd pdl
"    and evalu is called.
" on return, x4,x2,x5,x3 are undisturbed, 
"    aq = ap|-2 = evaluated object, and ap and x7 are unchanged.

	tra	0,0			exit used by evalhook

recurse:	xec	lisp_static_vars_$evalhook_status
	ldaq	ap|-2			check for easy cases and do them quickly
	cana	Unevalable,dl
	tnz	0,0
	cmpaq	ab|nil
	tze	0,0
	cana	Atsym,dl
	tze	full_recurse-*,ic		list -- hard case -- have to really recurse
	ldaq	ap|-2,*			atomic symbol -- get its value
	tze	3,ic			undefined?
	staq	ap|-2			  no, return it.
	tra	0,0

undefined_atom_error:
	" undefined atomic symbol -- error

		" atomic symbol which was undef is at ap|-2
		" returns by tra 0,0 with new value in aq and ap|-2
		" if necessary, pushes an evalframe

	ldaq	lisp_static_vars_$star_rset,*
	cmpaq	ab|nil
	tnz	undefined_atom_error_hard-*,ic

	lda	lisp_error_table_$undefined_atom
	tra	error-*,ic			error must return value in aq and ap|-2

undefined_atom_error_hard:	" push evalframe

	eax7	8,x7
	eppap	ap|2	copy atom to avoid destroying evalframe during error proc
	ldaq	ap|-4
	staq	ap|-2
	eax6	ap|-4
	sxl6	ab|frame.stack_ptr-6,x7
	eax6	sp|0
	stx6	ab|frame.dat1-6,x7
	ldx6	lisp_static_vars_$eval_frame+1
	stx6	ab|frame.prev_frame-6,x7
	eax6	ab|-6,x7
	stx6	lisp_static_vars_$eval_frame+1

	stx0	ab|frame.ret-6,x7			save return address
	lda	lisp_error_table_$undefined_atom
	tsx0	error-*,ic			go signal the error

		" now pop this evalframe

	ldx6	ab|frame.prev_frame-6,x7
	stx6	lisp_static_vars_$eval_frame+1
	ldx0	ab|frame.ret-6,x7			return addr saved
	eax7	-8,x7
	ldaq	ap|-2
	eppap	ap|-2		undo push above
	staq	ap|-2		some callers want it in stack
	tra	0,0

full_recurse:
	stx5	ab|svx5u,x7
	sxl2	ab|svx2l,x7
	sxl4	ab|svx4l,x7
	stx0	ab|svx0u,x7
	sxl3	ab|svx3l,x7
	eppap	ap|6			get new work area on marked pdl
	tsx5	eval_fcn-*,ic
	lxl4	ab|svx4l,x7
	ldx0	ab|svx0u,x7
	lxl2	ab|svx2l,x7
	ldx5	ab|svx5u,x7
	lxl3	ab|svx3l,x7
	staq	ap|form			return result in both aq and stack
	eppap	ap|form+2			restore caller's ap
	tra	0,0			return to caller of recurse


" symeval	SUBR 1 arg - evaluate a symbol.  used for compiled efficiency

	segdef	symeval

symeval:	ldaq	ap|-2		fetch argument
	cana	Atsym,dl		is it an atomic symbol?
	tze	symeval_loss-*,ic	no, error (if compiled, would be bug)
	ldaq	ap|-2,*		yes, get its value
	tze	symeval_loss-*,ic	and err if unbound
symeval_ret:
	eppap	ap|-2		pop argument
	tra	lisp_rtn_1-*,ic	and return

symeval_loss:
	tsx0	undefined_atom_error-*,ic
	tra	symeval_ret-*,ic
"
"pl1 - callable apply function

	entry	apply
apply:	tsx0	pl1_entry-*,ic
	tsx5	apply_com-*,ic

	tra	pl1_return-*,ic


"lisp - callable apply lsubr

	segdef	apply_

apply_:	cmpx5	-4,du			2 args?
	tnz	apply_with_3_args-*,ic
	eax5	lisp_retn-*,ic

" set up the pdl with form, fcn, argl as when evaling a fcn.
" set applybit to indicate that ap|form = fcn instead of full form
" go to common code with eval

apply_com:
	eax2	noteval+applybit
	ldaq	ap|-2
	eppap	ap|4
	staq	ap|argl
	ldaq	ap|form
	staq	ap|fcn
	tra	evaler-*,ic			return addr is in x5



"
" interface to lisp_error_

" called by tsx0, preserves x0,x5,x2,x4
" error code must be in the a.

error:	eax7	2,x7			going to push error code onto unmkd pdl
	staq	ab|-2,x7			errcode(1) from a, errcode(2) from q.
	tsx6	call_ext_out-*,ic		-- now call lisp_error_, which
	eppbp	lisp_error_$lisp_error_    will clear the unmkd pdl for us

" come here to call out to a pl1 program.
" x6 -> an eppbp instruction to get address of entry being called
" x0 =  return address
" x1,x2,x3,x4,x5 are saved (by the call macro)
"
" on return aq is loaded with value on top of marked pdl
" on entry, a is zeroed unless from error, where it is pushed onto unmkd pdl
"
" this code just saves things, updates the pl1 copies of
" the two stack pointers, and builds a stack frame from which to call out
"
" ***** this piece of code relies on the knowledge that the save macro does
" ***** not change any index registers except x7

call_ext_out:
	spriap	lisp_static_vars_$stack_ptr
	stx7	lisp_static_vars_$unmkd_ptr+1
	stc1	ab|in_pl1_code
	push				" ** this is where x6 must not change
	xec	0,x6			an eppbp instruction.
" *** here we rely on the new call macro doing an sreg and an lreg to save x0,x2,x4,x5
	call	bp|0(=v18/0,18/4,18/0,18/0)		no args arg list
	eaa	sp|16,*			pop stack frame
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au

	eppap	lisp_static_vars_$stack_ptr,*
	epbpab	lisp_static_vars_$unmkd_ptr,*
	ldx7	lisp_static_vars_$unmkd_ptr+1
	stz	ab|in_pl1_code
	ldaq	ap|-2			needed when unbnd-vrbl in recurse.
	tra	0,0

"

" eval with an a-list 2nd argument (actually a pdl pointer)

eval_with_2_args:
	eax7	2,x7
	tsx3	fetch_binding_context_ptr-*,ic	sets x4 to bcp to a bb
	epplb	ab|-2,x7				set up ptr to bb
	tsx3	reverse_binding_context-*,ic		reverse context to there
	tsx5	evalu-*,ic			now eval 1st arg in that context
	staq	ap|form				save result
	epplb	ab|-2,x7				set up ptr to bb
	tsx3	unwind_reversal_bb-*,ic		restore to calling context
	eax7	-2,x7				restore unmarked pdl
	ldaq	ap|form				put result in AQ
	tra	lisp_retn-*,ic			and return from type 1 subr


" hack for apply with 3rd arg a pseudo-a-list (pdl ptr)
" have to neutralize all the binding blocks between the top of
" the pdl and the pdl ptr.

apply_with_3_args:
	eax7	2,x7
apply_tsx3:
	tsx3	fetch_binding_context_ptr-*,ic
	epplb	ab|-2,x7
	tsx3	reverse_binding_context-*,ic
	tsx5	apply_com-*,ic		now do the apply
	staq	ap|form
	epplb	ab|-2,x7
	tsx3	unwind_reversal_bb-*,ic
	ldaq	ap|form
	eax7	-2,x7
	tra	lisp_retn-*,ic

" Routine to accept a lisp a-list-ptr (or binding-context-ptr), and
" convert it into a pointer to the lowest binding block on the unmarked
" pdl which is affected.  the input is in ap|-2 and is popped.
" the output is in x4.
" called by tsx3
" the pointer input to this routine has -2 in its left half and
" a pointer to the unmarked pdl in its right half.  NOTE that this
" is a change from the previous version in which it pointed at the marked pdl.
" The pointer to the unmarked pdl need not point exactly at a bb.
" ab|-2,x7 and ab|-1,x7 are used for temporary storage.

fetch_binding_context_ptr:
	ldaq	ap|-2
	cmpaq	ab|nil			nil means zero level context
	tze	fetch_bcp_nil-*,ic		which has to be special cased

	cana	Fixed,dl			make sure it is a fixnum
	tze	fetch_bcp_error-*,ic
	eax1	0,qu			make sure left half is -2
	cmpx1	-2,du
	tnz	fetch_bcp_error-*,ic
	eax4	0,ql			make a few other useless checks
	stx7	ab|-2,x7
	cmpx4	ab|-2,x7
	trc	fetch_bcp_error-*,ic	too high
	cmpx4	ab|marked_stack_bottom+1
	tnc	fetch_bcp_error-*,ic	too low

fetch_bcp_ret:
	eppap	ap|-2			pop argument
	tra	0,x3			and return

fetch_bcp_error:
	lcq	-fn_eval,dl		assume called by eval
	cmpx3	apply_tsx3+1,du
	tnz	2,ic
	 lcq	 -fn_apply,dl		no, called by apply

	lda	lisp_error_table_$not_pdl_ptr
	stx3	ab|-2,x7
	tsx0	error-*,ic		call error routine
	ldx3	ab|-2,x7			which returns with new data in ap|-2
	tra	fetch_binding_context_ptr-*,ic	so retry

fetch_bcp_nil:
	ldx4	ab|unmkd_stack_bottom+1
	tra	fetch_bcp_ret-*,ic
"
" reverse one binding block
"  x6	-> block to be reversed
"  x5	what to set its rev_ptr to
"  x0	calling reg
"  lp	-> lisp static
" aq, x1, all pointers are clobbered except lb

reversal:	stc1	lisp_static_vars_$binding_reversal_flag	lock interrupts
	epbpbb	ap|0		-> marked pdl
	eppap	ap|2		get temp on stack
	lxl1	ab|0,x6		pick up binding_block.bot_block
reverse_1_binding:
	cmpx1	ab|0,x6		reached top of block?
	tze	reverse_1_binding_aa-*,ic	yes, stop
	ldaq	bb|0,x1		pick up saved value
	staq	ap|-2		save it for a moment
	ldaq	bb|2,x1*		pick up current value of symbol bound
	staq	bb|0,x1		set as saved value
	ldaq	ap|-2		and set saved value as current value
	staq	bb|2,x1*		..
	eax1	4,x1		proceed to the next binding in this block
	tra	reverse_1_binding-*,ic

reverse_1_binding_aa:
	sxl5	ab|1,x6		yes, set this block's rev_ptr
	eppap	ap|-2		police area
	ldac	lisp_static_vars_$binding_reversal_flag	test & clear intr lock
	ana	=o7,dl		mask to just interrupt bits
	tze	0,x0		none set, return

" interrupt happened and was deferred - signal it now.
" the following code is copied from lisp_alloc_

	eax7	2,x7				store interrupt bits
	sta	ab|-2,x7
	spriap	lisp_static_vars_$stack_ptr	save environment
	stx7	lisp_static_vars_$unmkd_ptr+1
	stc1	ab|in_pl1_code
	tempd	arglist(4)
	push
	eppbp	lisp_static_vars_$unmkd_ptr,*	get address of intr code
	eppbp	bp|-2
	spribp	arglist+2
	ldaq	arg_list_1_hdr-*,ic
	staq	arglist
	call	lisp_default_handler_$alloc_fault(arglist)	saves all xr's, lb
	eaa	sp|16,*			now pop back to lisp
	sprisp	sb|20
	eppsp	sb|0,au
	epbpab	lisp_static_vars_$unmkd_ptr,*
	eppap	lisp_static_vars_$stack_ptr,*
	ldx7	lisp_static_vars_$unmkd_ptr+1
	stz	ab|in_pl1_code
	eax7	-2,x7			flush arg loc pushed earlier
	tra	0,x0			now return from reversal

" Procedure to reverse binding context down to a specified binding context pointer
"  x4	-> the bb which is last to reverse down to
"  x3	call reg
"  lp	-> lisp static
"  lb	-> 2 words on unmkd pdl to put the bb in
" uses
"  x6	-> current binding block
"  x5	-> newly-constructed reversal bb, (used to set rev_ptr's)
"  x1	temp
" aq, bb, bp clobbered
" x2 is guaranteed untouched
" NOTE:  the 2 words on unmkd pdl for the bb constructed are assumed already pushed

reverse_binding_context:
	eax5	lb|0			-> reversal bb to construct
	eax6	0,x5			init scan ptr
	stz	lb|0			set reversal-bb flag in dl
"	stx4	lb|0			set PDLP in du
	ldq	lisp_static_vars_$binding_top+1  set thread, clearing rev_ptr
	stq	lb|1
	stx5	lisp_static_vars_$binding_top+1  thread into bindings list

rbc00:	" trace thread of binding blocks until the pdl ptr is reached...

	cmpx4	ab|1,x6			gone down far enough?
	tpnz	rbc_ret-*,ic		yes, return (RELIES ON STACK = 64K)
	ldx6	ab|1,x6			no - chase thread to a block
	lxl1	ab|0,x6			check type of block
	tze	rbc01-*,ic		tra if a reversal block
	tsx0	reversal-*,ic		normal block - reverse it and set rev_ptr
	tra	rbc00-*,ic		and continue scanning pdl

rbc01:	cmpx4	ab|0,x6			reversal block - compare its PDLP to ours
	tpnz	rbc02-*,ic	*** KLUDGE *** relies on lisp stacks limited to 64K
	"its range is contained in ours. skip over it since it has already
	"done the reversals that we want
	ldx6	ab|0,x6			skip down to its PDLP
	tra	rbc00-*,ic		and look at next block below that

rbc02:	"its range exceeds ours - take the part of its range we want, and
	"reverse the rest, because it did the opposite of what we want.
	"this is referred to as the "extended range."

	sxl5	ab|1,x6			set rev_ptr to us to mark end of range
	eax1	0,x4
	ldx4	ab|0,x6			set scan limit to its PDLP
rbc03a:	cmpx1	ab|1,x6			set scan position to our PDLP, also
	tpnz	rbc03b-*,ic		setting our PDLP to really point at a bb
	ldx6	ab|1,x6
	tra	rbc03a-*,ic

rbc03b:	stx6	lb|0			set our pdlp
rbc03:	ldx6	ab|1,x6			and go down one more block
	tze	0,x3			return if no more
	lxl1	ab|0,x6			what type BB is this?
	tze	rbc04-*,ic		reversal - skip it
	lxl5	ab|1,x6			normal - reverse it but
	tsx0	reversal-*,ic		don't change its rev_ptr
rbc04:	cmpx4	ab|1,x6			done?
	tpnz	0,x3		*** KLUDGE *** relies on lisp stacks 64K
	tra	rbc03-*,ic

" come here to return from reverse_binding_context.
" the PDLP field is changed to be an accurate pointer to a binding block

rbc_ret:	stx6	lb|0		bb.pdlp := addr of lowest bb in range
	tra	0,x3

" Procedure to unwind a reversal bb
" called by tsx3 with the reversal bb at lb|0
" uses all the registers

unwind_reversal_bb:
	eax5	0		for clearing rev_ptr's
	eax6	lb|0		and begin scanning down stack
	ldx4	lb|0		pick up pdl ptr of this reversal bb
urbre:	eaa	lb|0		prepare to do r-r arithmetic in pointer register
	neg	0
	eppbb	0,au
urb00:	cmpx4	ab|1,x6		done?
	tpnz	urbxx-*,ic	yes (RELIES ON STACK BEING 64K)
	ldx6	ab|1,x6		no, thread through back_ptr
	lxl1	ab|1,x6		pick up its rev_ptr
	eax1	bb|0,x1		does it point at the block being reversed?
	tnz	urb00-*,ic	no - this block didn't change it so don't change back
	lxl1	ab|0,x6		yes - check type
	tze	urb01-*,ic	reversal bb - tra
	tsx0	reversal-*,ic	normal - reverse it and zero its rev_ptr
	tra	urbre-*,ic	and chain to next, fixing bb

" here the extended range begins, reverse everything without touching its rev_ptr

urb01:	ldx4	ab|0,x6		pick up its PDLP hwich limits our range
urb02:	cmpx4	ab|1,x6		done?
	tpnz	urbxx-*,ic	yes
	ldx6	ab|1,x6		no, thread through back_ptr
	lxl1	ab|0,x6		check its type
	tze	urb02-*,ic	ignore reversal bb's
	lxl5	ab|1,x6		normal bb's get reversed but rev_ptr left alone
	tsx0	reversal-*,ic
	tra	urb02-*,ic

urbxx:	ldx1	lb|1		now unthread this bb from bindings list
	stx1	lisp_static_vars_$binding_top+1
	tra	0,x3		and return
"
" this is the actual evaluator
" it is called by tsx5 with ap|-2 the object to be evaled.
" it returns with ap bumped by 6, the result in the aq,
"  x7 the same, and the contents of the other regs randomized.

	tra	evalu_exit-*,ic	used by evalhook

evalu:	xec	lisp_static_vars_$evalhook_status
	eppap	ap|6			room to work
	ldaq	ap|form			object to be evaled
	cana	Unevalable,dl
	tnz	0,5			if number or string, just return it
	cana	Atsym,dl
	tze	eval_fcn-*,ic
"Atomic symbol.  Return its value.  Error if undefined
	ldaq	ap|form,*			get value of atom
	tnz	0,5
	eppap	ap|form+2			undefined - give correctable error
	tsx0	undefined_atom_error-*,ic
	eppap	ap|-form-2
	"ldaq	ap|form			replacement value.(already in aq)
	tra	0,5

evalu_exit:
	eppap	ap|6			exit routine for evalhook
	tra	0,5

" evaluate a non-atomic expression

eval_fcn:	eax2	0			clear all flags
	eppbp	ap|form,*
	ldaq	bp|2			cdr = args
	staq	ap|argl
	ldaq	bp|0			car = fcn
	staq	ap|fcn

" apply, label, and funarg join us here. (by tsx5, with
"   x2, ap|form, ap|fcn, ap|argl properly set up.)

evaler:
	eax3	find_type_tv-*,ic

evaler1:

" set up the unified binding block, initially empty of bindings

	eax7	8,x7
	eax6	ap|0			= bot_block, for now = top_block too
	stx6	ab|-2,x7
	sxl6	ab|-2,x7
	eax4	0			-- binding block takes 0 words right now

" in *rset t mode, make an evalframe for baktrace & pdlframe

set_eval_frame: set_eval_frame_1:
	ldaq	lisp_static_vars_$star_rset,*
	cmpaq	ab|nil
	tze	make_no_frame-*,ic
	  eppbp	ab|-6,x7
	  eax6	sp|0			make frame.dat1, which = rel(sp),
	  canx2	applybit,du
	  tze	2,ic
	  orx6	1,du			+1 if in apply or map
	  stx6	bp|frame.dat1
	  eax6	ap|form,x4			-> form for pdlframe to get
	  sxl6	bp|frame.stack_ptr
	  ldx6	lisp_static_vars_$eval_frame+1
	  stx6	bp|frame.prev_frame
	  spribp	lisp_static_vars_$eval_frame
	  orx2	framebit,du

make_no_frame:
	tra	find_type-*,ic
find_type_tv:
"return transfer vector for find_type
	tra	eval_subrs_and_arrays-*,ic		"array
	tra	eval_subrs_and_arrays-*,ic		"subr
	tra	eval_lsubr-*,ic
	tra	eval_expr-*,ic
	tra	eval_fexpr-*,ic
	tra	eval_fsubr-*,ic
	tra	eval_lexpr-*,ic
"
" routine to bind all the atomic symbols in a lambda list
" ap|fcn,x4 is cons lambdalist body, as returned by find_type
" uses pre-existing binding_block
" called by tsx0.  Uses x1, bb.
" updates x4, ap, returns number of variables bound in x6
" just binds the variables - does not assign them to new values.

lambda_bind:
	eax6	0			init counter
	ldaq	ap|fcn,x4*
lambda_bind_1:
	cana	lisp_ptr.type,dl
	tnz	0,0			... end of the lambda - list
	eppap	ap|4
	eax4	-4,x4
	eax6	1,x6
	staq	ap|-2
	eppbp	ap|-2,*
	ldaq	bp|0			a lambda var
	staq	ap|-2
	cana	Atsym,dl			ok to bind?
	tze	bad_bound_var-*,ic		  nope.
	cmpaq	ab|nil
	tze	loser_binding_nil-*,ic
	ldaq	ap|-2,*			yes, ok to bind.
	staq	ap|-4
	eax1	ap|0
	stx1	ab|-2,x7			update binding_block.top_block
	ldaq	bp|2			(cdr of the lambda list)
	tra	lambda_bind_1-*,ic
"
" evaluator of fexpr's and macros
"
" binds the lambda-atom to the argument list.
" if a second lambda atom is present, binds it to a pdl ptr
"  so that it can be used with eval or apply as an a-list.
" then joins with expr code to eval lambda body.

eval_fexpr:
	canx2	bbf,du
	tze	3,ic			no pseudo bb, skip...
	eax1	ap|0
	tsx0	finish_bindings-*,ic
	tsx0	lambda_bind-*,ic
	cmpx6	1,du			just 1 lambda variable?
	tnc	bad_fcnl-*,ic		"fexpr (lambda nil ...
	tze	fexpr_1_arg-*,ic		yes, easy.
	eaq	ab|-2,x7			-> binding block
	qrl	18
	orq	-2,du
	lda	fixnum_type,dl
	staq	ap|-2,*			rebind 2nd arg
	ldaq	ap|argl,x4
	staq	ap|-6,*			rebind 1st arg
	tra	eval_lambda_body-*,ic

fexpr_1_arg:
	ldaq	ap|argl,x4
	staq 	ap|-2,*			rebind 1st (only) arg
	tra 	eval_lambda_body-*,ic

"

eval_lexpr:
	orx2	exprbit+lsubrbit,du
	eppap	ap|8			reserve space for binding block
	eax4	-8,x4			 but don't update binding_block.top_block yet.
	tra	arg_spreader-*,ic		comes back to args_spread_for_lexpr

eval_expr:

	orx2	exprbit,du

	" before spreading args, allocate enough space to bind
	" the lambda variables, but don't bind them until
	" after the args are spread because one of the args
	" might be a setq or something

	ldaq	ap|fcn,x4*
	eax1	ap|0			where first lambda var will be bound
	stx4	ab|-4,x7
expr_bb_alloc:
	cana	lisp_ptr.type,dl		end of lambda-list?
	tnz	expr_bb_fin-*,ic		  yes.
	eppap	ap|4			no, 1 more binding (at least)
	eax4	-4,x4
	staq	ap|-2
	eppbp	ap|-2,*
	ldaq	bp|2			cdr lambda-list
	tra	expr_bb_alloc-*,ic

expr_bb_fin:	" in last binding slot, save addr of first binding slot for lambda vars
		" (because there might be a label pseudo bb too)

	cmpx4	ab|-4,x7			anything in lambda list?
	tze	expr_nil-*,ic		 no.
	eaq	0,x1			 yes, save ptr to first
	lda	Uncollectable,dl
	staq	ap|-4
	tra	arg_spreader-*,ic

" expr with no lambda vars - still have to use arg_spreader for wrong_no_args check

expr_nil:	
	tra	arg_spreader-*,ic



args_spread_for_expr:
	canx2	lsubrbit,du
	tnz	args_spread_for_lexpr-*,ic
	ldaq	ap|fcn,x4*		which kind of expr?
	cana	lisp_ptr.type,dl
	tze	expr_bind-*,ic		 the kind with args
	canx2	bbf,du			the kind with no args.
	tze	3,ic
	eax1	ap|0			if necc., do pseudo-bb stuff
	tsx0	finish_bindings-*,ic

	cmpx3	0,du			we want no args. have we none?
	tnz	too_many_args_expr-*,ic	 no, barf.
	tra	eval_lambda_body-*,ic	yes, go eval fcn

expr_bind:

"ok, bind the lambda variables...
"
" finish making the binding block then pop the args off of the marked
" pdl and assign them to the lambda variables.

	epbpbb	ap|0
	canx2	already_spread,du
	tze	expr_bind_1-*,ic

" args are at bottom of pdl, pseudo binding block is at top

	ldx0	ap|argl,x4
	eax1	ap|0
	tra	expr_bind_0-*,ic

" args are at top of pdl, pseudo binding block is right below them.

expr_bind_1:
	tsx0	set_x1_args-*,ic
	eax0	0,x1			top of pseudo bb = base of args
expr_bind_0:
	sxl1	ab|-4,x7			save top of pseudo bb for later
	ldx1	bb|-3,x1			-> start of lambda var bindings

" at this point x0 -> args and x1 -> top of future binding block of lambda vars (pseudo bb)

	ldaq	ap|fcn,x4*		scan through lambda-list again 
	eax6	0			init counter
expr_binder:
	cana	lisp_ptr.type,dl		done?
	tnz	expr_assign_0-*,ic		   yes
	staq	bb|0,x1
	epplb	bb|0,x1*
	ldaq	lb|0			= the lambda-atom
	staq	bb|2,x1
	cana	Atsym,dl			make sure it is bindable
	tze	bad_bound_var_sp-*,ic
	cmpaq	ab|nil
	tze	loser_bind_nil-*,ic
	ldaq	bb|0,x0			get value of arg
	staq	bb|0,x1			store into pseudo binding block
					" lambda var will be bound to it later
	eax0	2,x0
	eax6	1,x6			count lambda vars
	eax1	4,x1
	ldaq	lb|2			cdr lamda-list
	tra	expr_binder-*,ic

loser_bind_nil:
	tra	loser_binding_nil-*,ic


expr_assign_0:
	stx6	ab|pdlptr,x7		check for right number of args
	cmpx3	ab|pdlptr,x7
	tze	3,ic
	tmi	too_few_args_expr-*,ic
	tra	too_many_args_expr-*,ic

" now that we have made a pseudo binding block out of the
" lambda variables and the values of the arguments, pop the args
" (no longer needed) off the pdl and call finish_bindings which
" will change the pseudo bb into a real bb bind thr lambda
" vars to the args.

	lxl1	ab|-4,x7			saved top of pseudo bb
	tsx0	finish_bindings-*,ic
	ldx1	ab|-2,x7			= binding_block.top_block
	eax0	ap|0,x4			so can adjust x4
	stx0	ab|-4,x7
	eppap	bb|0,x1			clear the spread args off the pdl
					" (finish_bindings sets bb)
	ldx4	ab|-4,x7			adjust x4
	sbx4	ab|-2,x7
	"tra	eval_lambda_body-*,ic	*** fall into eval_lambda_body
"
" come here to evaluate a lambda body which is the cdr of ap|fcn,
"  and consists of a list of 0 or more objects to be evaluated,
"  the value of the last of which is returned as the value of the lambda.
" After evaluating the lambda body, the topmost binding block is
"  unwound, restoring the lambda atoms to thwir former values.

eval_lambda_body:
	eppap	ap|2			place for return value
	eax4	-2,x4
	ldaq	ab|nil
	staq	ap|-2			initial value nil in case empty body

eval_lambda_body_loop:
	eppbp	ap|fcn,x4*		cdr down lambda body, first time is list of
					"  lambda list and lambda body
	ldaq	bp|2
	staq	ap|fcn,x4
	cana	lisp_ptr.type,dl
	tnz	end_eval_lambda_body-*,ic
	ldaq	ap|fcn,x4*
	staq	ap|-2			thing to pass to eval
	tsx0	recurse-*,ic
	tra	eval_lambda_body_loop-*,ic

end_eval_lambda_body:
	ldaq	ap|-2			move result down
	eppap	ap|-2
	eax4	2,x4

" come here to unwind & exit

fcn_fin:	staq	ap|qsrac,x4		save result of fcn
	canx2	mapf,du			from a map fcn?
	tnz	map_fcn_fin-*,ic		yes, go loop.
	tsx0	unbinder-*,ic

" if macro bit is set, send the macro around for another evaluation
" else return

freturn_join:
	ldaq	ap|qsrac			get result
	canx2	macrobit,du
	tze	0,5			return with result in aq,
					" and our 4 temp.'s on stack



	staq	ap|form			allowed since frame has been destroyed
	eppap	ap|form+2
	tra	evalu-*,ic		...and go around again

" this is code to finish up an freturn
" entered with the binding block already unwound, but the eval_frame still present
" there is nothing on either pdl except the usual 3 unmkd and 4 marked words - huh?
" we restore the index registers, get rid of the eval frame, and join up with fcn_fin

	segdef	freturn_real

freturn_real:
	getlp
	epbpab	lisp_static_vars_$unmkd_ptr,*	switch to lisp mode from pl1 mode
	eppap	lisp_static_vars_$stack_ptr,*
	ldx7	lisp_static_vars_$unmkd_ptr+1
	stz	ab|in_pl1_code

	" back in lisp mode -- restore index regs

	ldx5	ab|svx5u,x7
	lxl2	ab|svx2l,x7

	" ap|qsrac has the return value in it

	ldaq	ab|-2,x7				restore return_ptr in our caller's stack frame
	staq	sp|20				***** stack_frame.return_ptr
	canx2	mapf,du
	tnz	map_freturn		freturn to mapped fcn - go fix it up.

	" get rid of the stupid eval_frame

	canx2	framebit,du
	tze	3,ic
	 ldx1	 ab|frame.prev_frame-6,x7
	 stx1	 lisp_static_vars_$eval_frame+1
	eax7	-8,x7				flush the unmkd pdl
	tra	freturn_join			go join in with fcn_fin
"

" this routine is called to unwind the binding block,
"  and the eval frame (if there is one).   It clears
" the unmarked pdl and clears the binding block off
" of the marked pdl.  It must not change x3 (for map).
" also unwinds the funarg reversal binding block if fbb flag is on

unbinder:					" called by tsx0

	lxl1	ab|-2,x7			binding_block.bot_block
	cmpx1	ab|-2,x7			binding_block.top_block
	tze	lambda_completion		no bindings at all

	epbpbp	ap|0
	adwpbp	ab|-2,x7			binding_block.top_block
					" used to scan top - down
unwind_bindings:
	eppbp	bp|-4			-> next binding
	ldaq	bp|0			old value
	staq	bp|2,*			put back in atom.value
	eax1	4,x1			next binding
	cmpx1	ab|-2,x7			done? - check with binding_block.top_block
	tnz	unwind_bindings-*,ic

lambda_completion:
	eax1	ab|-2,x7			this bb may not have been threaded in (subr)
	cmpx1	lisp_static_vars_$binding_top+1
	tnz	3,ic
	 ldx1	 ab|-1,x7			binding_block.back_ptr
	 stx1	 lisp_static_vars_$binding_top+1

"if an evalframe was made, destroy it

	canx2	framebit,du
	tnz	destroy_evalframe
lambda_completion_1:
	canx2	fbb,du			funarg bb?
	tze	lambda_completion_2-*,ic	no, don't have to unwind it
	stx5	ab|svx5u,x7		stash registers
	stx0	ab|svx0u,x7
	sxl3	ab|svx3l,x7
	sxl4	ab|svx4l,x7
	epplb	ab|-8,x7			and unwind the funarg reversal bb
	tsx3	unwind_reversal_bb-*,ic
	lxl4	ab|svx4l,x7		now reload the regs
	lxl3	ab|svx3l,x7
	ldx0	ab|svx0u,x7
	ldx5	ab|svx5u,x7
lambda_completion_2:
	eppap	ap|0,x4			remove cruft from marked pdl
	eax7	-8,x7			remove cruft from unmarked pdl
	tra	0,0			& return.

destroy_evalframe:
	ldx1	ab|frame.prev_frame-6,x7
	stx1	lisp_static_vars_$eval_frame+1
	tra	lambda_completion_1
"
" the arguments are spread on the marked pdl where the arg function
"  can get at them.  The atomic symbol that was used as a lambda-list
"  is assigned to the number of arguments.  The pseudo-atom "argatom"
"  in lisp_static_vars_ is assigned to an uncollectable structure
"  representing the location and number of the stacked up args.
" then common code with expr is entered to eval the lambda
"  body, unwind the bindings, and return.

args_spread_for_lexpr:

	epbpbb	ap|0
	eax1	ap|0
	canx2	already_spread,du		args not at top of pdl?
	tnz	2,ic			yes, leave x1 = ap
	tsx0	set_x1_args-*,ic		-> spread arguments
	ldaq	ap|fcn,x4*		bind the atomic lambda list
	staq	bb|-2,x1
	eppbp	lisp_static_vars_$argatom  and the "argatom" used by arg function
	spribp	ab|-4,x7			- not really an atom, so have to set
	ldaq	ab|-4,x7			Uncollectable type-bits.
	ora	Uncollectable,dl
	staq	bb|-6,x1
	ldq	ap|argl,x4		find args.
	canx2	already_spread,du		are they below binding block?
	tnz	2,ic			yes
	eaq	0,x1			no, args are above binding block
	eaa	0,x3			number of arguments
	ora	Uncollectable,dl
	staq	bb|-8,x1
	lrl	54			shift number of args into ql
	lda	fixnum_type,dl
	staq	bb|-4,x1
	tsx0	finish_bindings-*,ic
	tra	eval_lambda_body-*,ic
"
eval_lsubr:
	orx2	lsubrbit,du
					" and fall into eval_subrs_and_arrays

eval_subrs_and_arrays:
	tra	arg_spreader-*,ic

args_spread_for_subr:
	canx2	lsubrbit,du
	tnz	args_spread_for_lsubr-*,ic

" subr - check arg count

	cmpx3	ap|fcn,x4*		compare number args to number in subr pointer
	tze	3,ic
	tnc	too_few_args_subr-*,ic
	trc	too_many_args_subr-*,ic

call_subr_bbf:
	canx2	bbf,du
	tze	call_subroutine-*,ic
	tsx0	set_x1_args-*,ic		do funarg stuff before calling subr
	tsx0	finish_bindings-*,ic

" to call a subr, etc.
" with the args spread on the marked pdl.
" For lsubrs, x6 contains -2*the number of arguments,
"  which is moved into x5 just before the call.
" ap|fcn,x4 points to the subr-link block which contains
"  a Multics dynamic link to the subr and an interface procedure.

call_subroutine:
	eppbp	ap|fcn,x4*		-> subr pointer
	stx5	ab|svx5u,x7		save regs through the call
	sxl2	ab|svx2l,x7
	eax5	0,x6			in case of lsubr, get arg count into x5
	tspbp	bp|1
returned_from_subroutine:
	ldx5	ab|svx5u,x7
	lxl2	ab|svx2l,x7
	lxl4	ab|-2,x7			since only the binding blocks is there now (the subr
	sbx4	ab|-2,x7			 has popped its args), restore proper x4
	tra	fcn_fin-*,ic		go finish up
" 
" args are spread out on stack just like for subr,
"  but -2 * argcount is passed in x5 so that first arg will be at ap|0,x5

args_spread_for_lsubr:

	canx2	bbf,du
	tze	3,ic
	tsx0	set_x1_args-*,ic
	tsx0	finish_bindings-*,ic
	tsx0	ck_lsubr_nargs-*,ic
	eaq	0,x3			get arg count...
	qrl	17			...times -2
	negl	0,du
	eax6	0,ql			will be moved into x5 ...
	tra	call_subroutine-*,ic	and go call it.



" like a subr with one argument, which is the unevaluated list of args

eval_fsubr:
	ldaq	ap|argl,x4			move arg list up to 1st arg position
	eppap	ap|2
	eax4	-2,x4
	staq	ap|-2
	tra	call_subr_bbf-*,ic		and go call it.
 
" routine to check number of arguments on an lsubr
" called with x3 containing number of args
" and ap|fcn,x4 being the subr ptr
" called by tsx0. Does not return if number of args is wrong

ck_lsubr_nargs:

" only check number of arguments in *rset t mode

	ldaq	lisp_static_vars_$star_rset,*
	cmpaq	ab|nil
	tze	0,0

" check against max & min number of args stored in subr ptr

	lda	ap|fcn,x4*		first word of subr pointer has max,min
	ana	=o000777,du		get min
	sta	ab|-4,x7
	lda	ap|fcn,x4*
	ana	=o777000,du		get max
	arl	9
	tnz	2,ic
	lda	=o777777,du		if 0, substitute a big number
	sta	ab|-3,x7
	cmpx3	ab|-4,x7
	tnc	too_few_args_lsubr-*,ic
	cmpx3	ab|-3,x7
	tze	2,ic
	trc	too_many_args_lsubr-*,ic
	tra	0,0
"
" routine to spread arguments

" entered with ap|argl,x4 pointing to argument list

" returns with arguments spread out on marked pdl
"  x3	number of arguments
"  x4	offset from new top of marked pdl to old top of marked pdl
" action is controlled by bits in x2
"  noteval	0 - arguments are evaluated
"		1 - arguments not evaluated
"  exprbit	controls where arg_spreader returns to
"		(NB: arg_spreader is called by tra, not tsx)
" on return, ap|argl,x4 is unchanged
" uses ap|qsrac,x4 to avoid modifying ap|argl,x4

arg_spreader:
	eax3	0		start with no args
	canx2	already_spread,du
	tnz	spread_adj-*,ic
	ldaq	ap|argl,x4	copy arg list
	staq	ap|qsrac,x4
spread1:
	cana	lisp_ptr.type,dl		any arguments left?
	tnz	spread_no_more-*,ic		no.
	ldaq	ap|qsrac,x4*	yes, get one
	eppap	ap|2		room to eval it
	staq	ap|-2
	eax3	1,x3		count arguments
	eax4	-2,x4		keep x4 pointing back below arguments
	canx2	noteval,du	should it be evaled?
	tnz	2,ic		no.
	tsx0	recurse-*,ic	yes, so do it.
	eppbp	ap|qsrac,x4*	cdr-ize argument list
	ldaq	bp|2
	staq	ap|qsrac,x4
	tra	spread1-*,ic

spread_no_more:
	canx2	exprbit,du
	tnz	args_spread_for_expr-*,ic
	tze	args_spread_for_subr-*,ic




" come here when spreading args that are already spread

" for subr, lsubr have to move them to top of pdl
" for expr, lexpr, can leave them where they are

spread_adj:
	ldx3	ap|argl+1,x4		get number of args
	canx2	exprbit,du		expr or subr?
	tnz	args_spread_for_expr-*,ic	expr, no problem
" subr, make sure args are at top of pdl
" they will be unless we had to create a binding block


	cmpx4	0,du			is there a binding block?
	tze	spread_adj_aa-*,ic		no, can use args where they stand

" have to move args up to top of pdl

spread_adj_0:
	lda	ap|argl,x4		au -> start of args
	epbpbb	ap|0
	eppbp	bb|0,au			bp -> start of args
	eax0	0,x3			number of args
spread_up:
	tze	args_spread_for_subr-*,ic	all done when x0 = 0
	eppap	ap|2
	eax4	-2,x4
	ldaq	bp|0
	staq	ap|-2
	eppbp	bp|2
	eax0	-1,x0
	tra	spread_up-*,ic


" nothing above the args but this ap|form, etc.
" so we can remove the eval frame and call the
" subr with the args in place

spread_adj_aa:
	canx2	fbb,du			can't do this if a funarg
	tnz	spread_adj_0-*,ic

	ldaq	lisp_static_vars_$star_rset,*
	cmpaq	ab|nil			- in *rset t mode must keep eval frame for baktrace
	tnz	spread_adj_0-*,ic
	canx2	framebit,du
	tze	3,ic
	  ldx1	  ab|frame.prev_frame-6,x7
	  stx1	  lisp_static_vars_$eval_frame+1
	canx2	lsubrbit,du
	tnz	spread_for_lsubr-*,ic
	cmpx3	ap|fcn,*			check number of args
	tze	3,ic
	tnc	too_few_args_subr-*,ic
	trc	too_many_args_subr-*,ic
call1_call:
	eppbp	ap|fcn,*
	eppap	ap|form
	eax7	-8,x7			get rid of junk on unmkd pdl
	tspbp	bp|1
	tra	call1_rtn_1-*,ic

spread_for_lsubr:
	tsx0	ck_lsubr_nargs-*,ic
	lxl5	ap|argl+1
	tra	call1_call-*,ic
" 
" routine to determine type of function being used.

" on entry ap|fcn,x4 is original function -- usually atom.
" on exit, ap|fcn,x4 is function actually to be used, ass follows:
"  subr,array,fsubr,lsubr:	pointer to subr-link block
"  expr,fexpr,lexpr,macro,lambda:
"			cdr of lambda-expression,
"			i.e. cons of lambda-list and body


" register usage
" ap|qsrac,x4 points to property list
" ap|fcn,x4 comes in with function, returns with real function, dep on type
" ap|argl,x4 comes in with args, is reset to ap|form if macro
"  bp	 "
"  x3	points to return transfer vector
"  x6     temporary, + fexpr indicator in ck_lambda
"  aq	in property - list searching loop, contains current
"		indicator (= bp|0).
"  x4	offset from top of marked pdl of ap|form, etc.
" the bits in x2 exprbit,lsubrbit are NOT set by find_type.
" however, macrobit is set (a macro looks like a fexpr
"  except that this bit is turned on, causing re-evaluation later)


find_type:	" x3 points to return transfer vector, entries in the following order:
		" array,subr,lsubr,expr,fexpr,fsubr,lexpr

	equ	array_offset,0
	equ	subr_offset,1
	equ	lsubr_offset,2
	equ	expr_offset,3
	equ	fexpr_offset,4
	equ	fsubr_offset,5
	equ	lexpr_offset,6

		" NOTE: nil can never be a function because this code doesn't
		" know how to get at the property list of nil.

	anx2	-already_autoloaded_once-1,du " turn off the already autoloaded bit
find_type_reenter:
	ldaq	ap|fcn,x4
	cana	Atsym,dl			check for symbol...most common case
	tze	unsymbolic_function
	eppbp	ap|fcn,x4*
	epplb	lisp_static_vars_$function_properties	for rpt loop.
find_type_1:
	ldaq	bp|2		-> plist
	cana	lisp_ptr.type,dl
	tnz	end_of_plist-*,ic
	eppbp	bp|2,*
	ldaq	bp|0		get the indicator
	eax6	0		free index register used in rpt loop
	rpt	8,2,tze		scan all 8 indicators, and skip if equal
	cmpaq	lb|0,x6
	ttf	fn_checks-2,x6	rpt leaves x6 2 too high.
skip_autoload:
	eppbp	bp|2,*		" try again on next property.
	tra	find_type_1
fn_checks:
	eax0	subr_offset,x3
	tra	cksubr		" subr

	eax0	lsubr_offset,x3
	tra	cksubr		" lsubr

	eax0	fsubr_offset,x3
	tra	cksubr		" fsubr

	eax6	0		" set x6 0 for ck_lambda
	tra	ck_lambda		" expr .. doesn't return

	tsx6	ck_lambda		" fexpr .. doesn't return(sets x6 non-zero too)
	drl	0

	eax0	array_offset,x3	" return for array
	tra	cksubr		" array

	tra	ck_macro		" macro
	drl	0		" doesn't return

	tra	ck_autoload	" autoload
	drl	0		" doesn't return

" Routine to check for lambda forms (or symbols - synonym hack)
" Exits to appropriate transfer vector entry
" called with x6 non zero for fexprs and macros.

ck_lambda:
	  ldaq	  bp|2,*		make sure is lambda expression
	  staq	  ap|fcn,x4
	  cana	  Atsym,dl	Atomic symbol instead of list as fcnl property
	  tnz	  find_type-*,ic
	  eppbp	  ap|fcn,x4*	lambda expression, get cdr which is lambda-list & body
	  ldaq	  bp|0
	  cmpaq	  lisp_static_vars_$lambda
	  tnz	  bad_fcnl_form-*,ic
	  ldaq	  bp|2
xx_lambda:  staq	  ap|fcn,x4
	  cmpx6	  0,du			fexpr or macro?
	  tnz	  fexpr_offset,x3		yes, appropriate exit
	  canx2	  macrobit,du		Is this a linked macro def?
	  tnz	  fexpr_offset,x3		Yup, fexpr/macroize it.
	  ldaq	  ap|fcn,x4*		check for lexpr
	  cmpaq	  ab|nil
	  tze	  expr_offset,x3
	  cana	  Atsym,dl
	  tnz	  lexpr_offset,x3		yes.
	  tra	  expr_offset,x3

ck_macro:
	  canx2	  applybit,du	macros may not be applied!
	  tnz	  illegal_use_of_a_macro-*,ic
	  orx2	  macrobit,du
	  ldaq	  ap|form,x4	arg to macro is whole body
	  staq	  ap|argl,x4
	  tsx6	  ck_lambda-*,ic

illegal_use_of_a_macro:
	  canx2	  ignore_macros,du	is this an error?
	  tnz	  skip_autoload-*,ic  no, just ignore the macro prop
	  tra	  bad_fcnl_form-*,ic  yes, barf

ck_autoload:
	canx2	already_autoloaded_once,du
	tnz	skip_autoload		" if already autoloaded, try next indicator
	orx2	already_autoloaded_once,du	remember that we did
	ldaq	lisp_static_vars_$user_intr_array+2*(18-1),*	user interrupt 18.
	cmpaq	ab|nil
	tze	skip_autoload		if autoload interrupt not enabled.
	eppap	ap|6
	staq	ap|-6
	ldaq	bp|2,*			load value under property
	staq	ap|-2
	ldaq	ap|fcn-6,x4		" remember we have pushed 6 words on
	staq	ap|-4			" pass cons of name and autoload prop.
	tsx0	call_cons
	eax7	10,x7
	stx1	ab|-10,x7
	stx2	ab|-9,x7
	stx3	ab|-8,x7
	stx4	ab|-7,x7
	stx5	ab|-6,x7
	eax5	-4
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	funcall
	ldx1	ab|-6,x7
	ldx2	ab|-5,x7
	ldx3	ab|-4,x7
	ldx4	ab|-3,x7
	ldx5	ab|-2,x7
	eax7	-6,x7
	tra	find_type_reenter		and try again to get function



end_of_plist:	" atom has no functional properties, eval its value
	orx2	went_through_value_cell,du
	ldaq	ap|fcn,x4*		atom.value
	tze	undef_fcn-*,ic	  if undefined.
	cmpaq	ap|fcn,x4			Is it bound to itself (e.g. nil)?
	tze	undef_fcn-*,ic		  yes, avoid embarrassing loop.
	staq	ap|fcn,x4
	tra	find_type-*,ic

unsymbolic_function:
	cana	lisp_ptr.type,dl
	tze	non_atom_fcn
	cana	Subr,dl
	tnz	subr_offset,x3		a direct subr pointer.
	tra	undef_fcn

non_atom_fcn:	" non-functional function, so eval it.


" check for lambda expression or label expression, since we now know it's a list

	eppbp	ap|fcn,x4*
	ldaq	bp|0		car of the list
	eax6	0
	epplb	lisp_static_vars_$lambda
	rpt	3,2,tze
	cmpaq	lb|0,x6	" lambda, label, and funarg are together.
	ttn	x13
	ldaq	bp|2
	tra	*+1-2,x6		x6 is set 2 too high on successful compare

	eax6	0
	tra	xx_lambda		jump to lambda code

	staq	ap|fcn,x4		set fcn
	tra	eval_label

	staq	ap|fcn,x4
	tra	eval_funarg

" just a random list, eval it and use its value as the function

x13:	ldaq	ap|fcn,x4
	orx2	went_through_value_cell,du
	eppap	ap|2
	staq	ap|-2
	tsx0	recurse-*,ic
	"ldaq	ap|-2		(the result is really already in aq, also)
	eppap	ap|-2		back up ap, from call.
	staq	ap|fcn,x4		and restore new function.
	tra	find_type-*,ic


cksubr:	ldaq	bp|2,*			get the supposed subr pointer
	cana	Subr,dl
	tze	undef_fcn-*,ic		not a subr ptr -- barf.
	staq	ap|fcn,x4			yes, subr ptr is fcn we are applying
	canx2	macrobit,du		Is this a subr-macro?
	tnz	fsubr_offset,x3		Treat like fsubr
	tra	0,0

ck_bound_var:			" procedure to check if aq contains
				" something that can legally be bound.
				" the object being checked must be in both aq & ap|-2
	cana	Atsym,dl
	tze	bad_bound_var-*,ic	if not even an atomic symbol, barf.
	cmpaq	ab|nil
	tnz	0,0		ok.

" loser trying to bind nil.  Give him a nihil ex nihile message

loser_binding_nil:
	lda	lisp_error_table_$nihil_ex_nihile
	tra	error-*,ic	...never returns

" eval a funarg, which is generated by *function
"  and looks like: (funarg <fcn> . <pdl ptr> )

" stashes the pdl_ptr and sets bbf and fbb flags
" so that finish_bindings will reverse context back to this pdl ptr,
" after the arguments have been evaled.
" substitutes the function from the funarg for the funarg and goes
" back into find_type to handle the substituted fnction

eval_funarg:
	eppbp	ap|fcn,x4*		-> cdr of the funarg list
	ldaq	bp|0			... the function
	staq	ap|fcn,x4
	orx2	bbf+fbb+went_through_value_cell,du
	lxl1	bp|3			assume proper pdl ptr put by *function
	tnz	2,ic			0 cuases lossage so check...
	 eax1	 1
	stx1	ab|funarg_pdlptr,x7
	tra	find_type-*,ic
"
" routine to make a pseudo binding block into a real binding block
" this is called after argument evaluation, when it safe to make bindings
" for funarg, label.

" called by tsx0
" changes only registers x0, x1, x6, aq, lb, bb
" sets bb to segment number of marked pdl

" when called by tsx0, pseudo bb extends from binding_block.top_block to bb|0,x1

finish_bindings:
	canx2	fbb,du			need a reversal bb?
	tze	finish_bindings_aa-*,ic	no
	stx5	ab|svx5u,x7		save registers
	stx0	ab|svx0u,x7
	sxl3	ab|svx3l,x7
	sxl4	ab|svx4l,x7
	sxl1	ab|svx2l,x7
	ldx4	ab|funarg_pdlptr,x7	pick up pdl ptr to be used
	epplb	ab|-8,x7			set ptr to where to put bb
	tsx3	reverse_binding_context-*,ic	switch worlds
	lxl1	ab|svx2l,x7
	lxl4	ab|svx4l,x7		and get registers back
	lxl3	ab|svx3l,x7
	ldx0	ab|svx0u,x7
	ldx5	ab|svx5u,x7

finish_bindings_aa:
	stx1	ab|pdlptr,x7		save top of pseudo bb for compare
	ldx1	ab|-2,x7			binding_block.top_block, = bottom of pseudo bb
	epbpbb	ap|0
	eppap	ap|2			temp.
					"that gets garbage collected

	ldq	lisp_static_vars_$binding_top+1
	stq	ab|-1,x7			now thread in this block
	eaq	ab|-2,x7
	stq	lisp_static_vars_$binding_top+1

fin_loop: cmpx1	ab|pdlptr,x7		done whole pseudo bb?
	tze	fin_xx-*,ic			  yes, return.
	ldaq	bb|0,x1			no, get new value
	staq	ap|-2			save it
	ldaq	bb|2,x1*			get old value
	staq	bb|0,x1			put it in binding block
	eax1	4,x1
	stx1	ab|-2,x7			update binding_block.top_block
	ldaq	ap|-2			assign new value to the atom
	staq	bb|2-4,x1*
	tra	fin_loop-*,ic

fin_xx:	eppap	ap|-2			pop off our temp
	tra	0,0



" proc to set x1 and bb to point at the spread args
" called by tsx0
" uses the arg count in x3
" also sets au to offset from top of pdl to 1st arg
" thus return values are bb|,x1=abs loc, au=rel loc

set_x1_args:
	epbpbb	ap|0
	eaa	0,x3			get arg count
	als	1			- each arg takes 2 words
	neg	0
	eax1	ap|0,au
	tra	0,0
"
	segdef	stfunction	- the lisp *function fsubr, which makes funargs

stfunction:

" on entry ap|-2 is arg list, i.e. ( <fcn> . nil)
" we want to return the list (funarg <fcn> . <pdlptr> )

" this function is equivalent to:
" (defun *function fexpr (x y) (cons 'funarg (cons (car x) y)))
" modified 73.11.02 by DAM to get rid of bug of assuming that there is a binding
"	block for our own invocation

	eppap	ap|4		room for 3 things
	ldaq	ap|-6,*		get our first (and only) arg - the function
	staq	ap|-4
	ldx1	lisp_static_vars_$binding_top+1 -> most recent binding_block
	tze	stfunction_00-*,ic		if no bb at all, don't give 0 pdl ptr
	lxl0	ab|0,x1			Kludgey way to check if we have own binding block.
	cmpx0	ab|0,x1			empty binding blocks are only generated by evaluator,
	tnz	2,ic			plus it doesn't hurt to skip over an empty b.b.
	ldx1	ab|1,x1			this is empty, prob. our own - skip over it
	eaq	0,x1			-> binding block itself
	tnz	2,ic
stfunction_00:
	eaq	ab|unmkd_stack_bottom,*	no binding_blocks, use stack base addr
	qrl	18
	orq	-2,du
	lda	fixnum_type,dl
	staq	ap|-2
	ldaq	lisp_static_vars_$funarg
	staq	ap|-6
	eax7	6,x7
	tsx0	call_cons-*,ic
	tsx0	call_cons-*,ic
	eax7	-6,x7
	ldaq	ap|-2
	eppap	ap|-2
	tra	lisp_rtn_1-*,ic
"
" handle functional forms such as (label foo (cruft))

" pseudo binds the function name to the function, then substitutes
" the new function for the label-expression and goes back to find_type.

" NB: atoms with functional properties cannot be successfully
" labelled to a recursive function since the property list
" is checked before the value. However, this is compatible
" since MACLISP has this same bug (or feature).

eval_label:
	eppbp	ap|fcn,x4*
	ldaq	bp|0			function name
	eppap	ap|4
	eax4	-4,x4
	staq	ap|-2
	tsx0	ck_bound_var-*,ic
	orx2	bbf+went_through_value_cell,du	set flag for pseudo bb existence
	ldaq	bp|2,*			2nd arg to label is function
	staq	ap|-4			rebind it.
	staq	ap|fcn,x4
	tra	find_type-*,ic		now proceed with the labelled function
"
" Evalhook stuff

" lisp_static_vars_$evalhook_status contains one
" of the following two instructions:

	segdef	evalhook_on_status,evalhook_off_status

evalhook_off_status:
	nop	0		evalhook checking disabled

evalhook_on_status:
	tsx6	evalhook_check

" Come here if evalhook checking is enabled.
" ap|-2 contains the item being evaluated.
" x1 and x6 are usable but all other registers are to be preserved
" if the value of evalhook is non-null it is applied
" in place of the evaluation that was to be done


evalhook_check:
	ldaq	lisp_static_vars_$evalhook_atom,*
	cmpaq	ab|nil		evalhook on?
	tze	0,x6		no, go on evaling

evalhook_trap:
	eax1	0,x7
	eax7	15+32,x7
	anx7	-16,du
	spri	ab|-32,x7
	sreg	ab|-16,x7

	eppap	ap|8		generate call to apply
	staq	ap|-8		saved value of evalhook
	staq	ap|-4		function to be applied
	ldaq	lisp_static_vars_$evalhook_atom
	staq	ap|-6		atom to be bound
	ldaq	ap|-10		form being evaled
	staq	ap|-2
	eax1	ap|-4		top
	stx1	ab|-12,x7
	eax1	ap|-8		bottom
	sxl1	ab|-12,x7
	lda	lisp_static_vars_$binding_top+1
	sta	ab|-11,x7
	eax1	ab|-12,x7
	stx1	lisp_static_vars_$binding_top+1
	ldaq	ab|nil		evalhook is bound, turn off
	staq	ap|-6,*

	sprilp	ab|-8,x7		prime return blocks
	sprilp	ab|-4,x7

	stcd	ab|-2,x7		ncons the 2nd arg to apply
	tra	lisp_alloc_$ncons_
	eppap	ap|2		push result back on stack
	staq	ap|-2

	eax5	-4
	stcd	ab|-2,x7		now apply the evalhooker
	tra	apply_-*,ic

	staq	ap|-6		returned value is new form to eval
	ldaq	ap|-4		restore evalhook value
	staq	ap|-2,*
	ldx1	ab|-3,x7		unbind
	stx1	lisp_static_vars_$binding_top+1
	lreg	ab|-8,x7		restore state
	lpri	ab|-24,x7
	eax7	0,x1
	ldaq	ap|-2		get result in aq
	tra	-2,x6		and return from the evaluation


" The evalhook function

	segdef	evalhook

evalhook:	eax7	4,x7		save evalhook_status, bind evalhook_atom
	lda	lisp_static_vars_$evalhook_status
	sta	ab|-4,x7
	lda	evalhook_on_status-*,ic
	sta	lisp_static_vars_$evalhook_status
	eppap	ap|6
	ldaq	lisp_static_vars_$evalhook_atom
	staq	ap|-4
	ldaq	ap|-4,*
	staq	ap|-6
	eax1	ap|-2
	stx1	ab|-2,x7
	eax1	ap|-6
	sxl1	ab|-2,x7
	lda	lisp_static_vars_$binding_top+1
	sta	ab|-1,x7
	eax1	ab|-2,x7
	stx1	lisp_static_vars_$binding_top+1

	ldaq	ap|-8		bind evalhook to 2nd arg
	staq	ap|-4,*
	ldaq	ap|-10		eval first arg
	staq	ap|-2
	tsx5	evalu+1-*,ic	go join evaluator after evalhook test
	eppap	ap|-6

	staq	ap|-8		store result back over first arg
	ldaq	ap|-4		unbind evalhook
	staq	ap|-2,*
	ldx1	ab|-1,x7		undo binding block
	stx1	lisp_static_vars_$binding_top+1
	lda	ab|-4,x7		restore evalhook_status
	sta	lisp_static_vars_$evalhook_status
	eax7	ab|-4,x7		clear one pdl
	ldaq	ap|-8		get return value
	eppap	ap|-8		clear other pdl
	tra	lisp_rtn_1-*,ic	and return

" error handlers.

bad_fcnl_form:
				" uncorrectable error!
	ldaq	ap|fcn,x4
	eppap	ap|2
	staq	ap|-2
	lda	lisp_error_table_$bad_function
	tsx0	error-*,ic


bad_fcnl:

	ldaq	ap|form,x4*		the fnc name
	staq	ap|fcn,x4
	tra	bad_fcnl_form-*,ic


undef_fcn:
	ldaq	ap|fcn,x4
	eppap	ap|2
	staq	ap|-2
	lda	lisp_error_table_$undefined_function
	tsx0	error-*,ic
	"ldaq	ap|-2
	eppap	ap|-2
	staq	ap|fcn,x4
	tra	find_type-*,ic

subrcall_error:
	tsx0	foocall_error-*,ic
	lda	lisp_error_table_$subrcall_bad_ptr

lsubrcall_error:
	tsx0	foocall_error-*,ic
	lda	lisp_error_table_$lsubrcall_bad_ptr

arraycall_error:
	tsx0	foocall_error-*,ic
	lda	lisp_error_table_$arraycall_bad_ptr

arraycall_mismatch:
	tsx0	foocall_error-*,ic
	lda	lisp_error_table_$arraycall_wrong_type

foocall_error:
	ldaq	ap|fcn		the faulty argument
	staq	ap|-2		error is uncorrectable
	xec	0,x0		lda the error code
	tsx0	error-*,ic	never returns.


illegal_f_fcn:	" call from compiled code to fsubr/fexpr with args already evaled

	eppap	ap|2
	ldaq	ap|form-2,x4
	staq	ap|-2
	lda	lisp_error_table_$bad_f_fcn
	tsx0	error-*,ic			never returns - uncorrectable


bad_bound_var_sp:
	epplp	ab|-4,x7*			get back our lp
	eppap	bb|4,x1			from expr_binder, make sure that bad bv
					" is really located at ap|-2

bad_bound_var:			" uncorrectable

	" the non-atomic symbol trying to be bound is in ap|-2
	" callers of ck_bound_var, be sure of this!!!!

	lda	lisp_error_table_$bad_bv
	tsx0	error-*,ic

wrong_no_args_expr:
too_many_args_expr:			" correctable - by substituting a whole new form
too_few_args_expr:
	ldaq	ap|fcn,x4*			-> the lambda list
	eppap	ap|4
	staq	ap|-2				and fall into wna_com

" make list of form and its lambda list


wna_com:
	eppap	ap|2			total of 6. up
	ldaq	ap|form-6,x4
	canx2	applybit,du		need to construct fake form?
	tze	wna_com_1-*,ic		  no.
	canx2	already_spread,du		is there an argl?
	tnz	wna_com_1-*,ic		no, can't make fake form so use(atomic)
					" function name in place of form.
	staq	ap|-2
	eppap	ap|2
	ldaq	ap|argl-8,x4
	staq	ap|-2
	tsx0	call_cons-*,ic
	ldaq	ap|-2
wna_com_1:
	staq	ap|-6
	ldaq	ab|nil
	staq	ap|-2
	tsx0	call_cons-*,ic
	tsx0	call_cons-*,ic
	lda	lisp_error_table_$wrong_no_args
	tsx0	error-*,ic
	"ldaq	ap|-2
	eppap	ap|-2
	anx2	-macrobit-1,du		clear macrobit
	canx2	mapf,du		from map?
	tnz	map_abending-*,ic	yes.
	tra	fcn_fin-*,ic

wrong_no_args_subr:
too_many_args_subr:
too_few_args_subr:

	" make list of form and fake args property (nil.nargs)

	ldq	ap|fcn,x4*
	qrl	18
	lda	fixnum_type,dl
	eppap	ap|6
	staq	ap|-2
	ldaq	ab|nil
cons2zz:	staq	ap|-4
	tsx0	call_cons-*,ic
	tra	wna_com-*,ic


wrong_no_args_lsubr:
too_many_args_lsubr:
too_few_args_lsubr:

	" make list of form and fake args property (min.max)

	ldq	ap|fcn,x4*
	qrl	27			max
	lda	fixnum_type,dl
	eppap	ap|6
	staq	ap|-2
	ldq	ap|fcn-6,x4*
	qrl	18
	anq	=o777,dl			min
"	lda	fixnum_type,dl
	tra	cons2zz-*,ic

"
"
"	"let" fsubr    BSG 09/12/78
"
	segdef	let
let:	eppap	ap|6		Allocate marked PDL work area.
	eax7	8,x7		Allocate binding block
	eax6	ap|0		= bot block, now also top.
	stx6	ab|-2,x7		Init binding block ctrs.
	sxl6	ab|-2,x7
	eax4	0		Current size (-) of binding blk.
"
"	Dredge out the vars for the binding block
"
	ldaq	ap|form		(let . foo)?
	cana	lisp_ptr.type,dl
	tnz	bad_fcnl-*,ic
	eppbp	ap|form,*		bp -> (((var1 val1)....
	ldaq	bp|0		s/b let list
	cmpaq	ab|nil		special case this atomic l.l.
	tze	let_ll_done
	cana	lisp_ptr.type,dl	Is it atomic, not nil?
	tnz	bad_fcnl-*,ic	Yes, (let foo ..)  Barf loudly.
let_bind_1: 			"Scan let list.
	"Rest of let list is in AQ, x4 is -4* nargs processed.
	cana	lisp_ptr.type,dl	Done?
	tnz	let_ll_done	All done.
	eppap	ap|4		Push marked pdl
	eax4	-4,x4
	staq	ap|argl,x4	Set for indirect
	eppbp	ap|argl,x4*	bp -> letlist
	ldaq	bp|0		Letlist element
	cana	lisp_ptr.type,dl	Atomic, i.e. (let (foo ...
	tnz	bad_fcnl-*,ic	This is what interpreters are for.
	ldaq	bp|0,*		car of letlist = symbol
	staq	ap|-2		Save lambda var
	cana	Atsym,dl		Make lambda var checks.
	tze	bad_bound_var-*,ic
	cmpaq	ab|nil
	tze	loser_binding_nil-*,ic
	ldaq	ap|-2,*		Get current val
	staq	ap|-4		Save in binding block.
	eppbp	ap|argl,x4*	Point to "rest" of letlist
	ldaq	bp|2		Get that cdr.
	tra	let_bind_1-*,ic

let_ll_done:
	eax1	ap|0
	stx1	ab|-2,x7		set binding_block.topblock.
	ldq	lisp_static_vars_$binding_top+1 Avoid fbb hackery for let.
	stq	ab|-1,x7
	eaq	ab|-2,x7
	stq	lisp_static_vars_$binding_top+1
"	Now eval the things to be assigned.

	ldaq	ap|form,x4*	Point at cons which heads let cdr.
	staq	ap|argl,x4	Now have let list.

	eax3	0,x4		Duplicate x4.
	eppap	ap|2		Push work var.
let_bind_2:
	cana	lisp_ptr.type,dl	Is it done?
	tnz	let_bind_2_done	yes.

	eppbp	ap|argl-2,x4*	Point at current letlist head.
	eppbp	bp|0,*		Point at car, guaranteed non-atomic
	ldaq	bp|2		Is there a cadr?
	cana	lisp_ptr.type,dl	...
	tnz	let_bind_2_gets_nil no
	ldaq	bp|2,*		Get the cadr.
	staq	ap|-2
	tsx0	recurse-*,ic	Get the result of evalling it.
	tra	*+2-*,ic
let_bind_2_gets_nil:
	ldaq	ab|nil
	staq	ap|2-2,3*	-2 for atsym, 2 for work temp.
	eax3	4,3		Account for one var.
	eppbp	ap|argl-2,x4*	Point a letlist cons.
	ldaq	bp|2		Get cdr.
	staq	ap|argl-2,x4	Cdr down list.
	tra	let_bind_2	Loop some more.
"
"	Now make like we were a real lambda.
"
let_bind_2_done:
	eax2	0		Zero all of Moon's flags.
	eppap	ap|-2		Drop the work temp.
	ldaq	ap|form,x4	Get letlist and body.
	staq	ap|fcn,x4		Put where eval_lambda_body wants it.
	tsx5	eval_lambda_body-*,ic
	tra	lisp_retn-*,ic
"
" arg & setarg subrs for lisp

	segdef	arg,setarg,listify

argcom:	ldaq	ap|-2			argument which is arg number.
	cmpa	fixnum_type,dl
	tze	5,ic
wta_arg:	  lda	  lisp_error_table_$meaningless_argument_number
	  ldq	  -1,x2			get fcn name code.
	  tsx0	  error-*,ic
	  tra	  argcom-*,ic
	cmpx2	qqlistify,du		see if called by listify.
	tnz	not_listify-*,ic
	eax1	0,ql
	tpl	argcom1-*,ic		if positive or zero, ok.
	ldaq	lisp_static_vars_$argatom	check for lexpr
	tze	bad_use_arg-*,ic
	adx1	lisp_static_vars_$argatom
	tmi	wta_arg-*,ic		if want more args than we got, error.
	ldx1	lisp_static_vars_$argatom now get last arg addr.
	tra	argcom2-*,ic
not_listify:
	cmpq	1,dl
	tmi	wta_arg-*,ic
argcom1:
	eax1	0,ql

" is there really an arg atom?

	ldaq	lisp_static_vars_$argatom
	tze	bad_use_arg-*,ic		****** argatom inited to 0 ******
argcom2:
	cmpx1	lisp_static_vars_$argatom   check against arg count
	tze	2,ic
	tpl	wta_arg-*,ic
	epbpbb	ap|0
	eppbp	bb|0,qu			start of arguments on stack
	eppbp	bp|-1,x1
	eppbp	bp|-1,x1			(twice because args are double-words
	tra	0,5

arg:	eax2	qqarg-*,ic
	ldaq	ap|-2			get argument
	cmpaq	ab|nil			if nil, get arg count!
	tnz	arg_non_nil
	ldaq	lisp_static_vars_$argatom
	tze	bad_use_arg-*,ic
	lrl	54			move arg count to q
	lda	fixnum_type,dl
	tra	arg_return
arg_non_nil:
	tsx5	argcom-*,ic
	ldaq	bp|0			the arg
arg_return:
	eppap	ap|-2
	tra	lisp_rtn_1-*,ic

listify:	eax2	qqlistify-*,ic		to get right name for wta message.
	tsx5	argcom-*,ic		go to common code for arg and setarg,
"					which will get address of last arg to be in list into bp,
	lda	ap|-1			load number of things to be consed.
	tpl	2,ic
	neg	0,du			" make sure positive.
	eax1	0,al			and put into x1.

	ldaq	ab|nil			get nil result.
	eax7	2,x7
lstfy_loop:eax1	-1,x1			decrement count of things to be consed.
	tmi	lstfy_end
	sprpbp	ab|-2,x7			save ptr to arg.
	stx1	ab|-1,x7			and number of args.
	eppap	ap|4			get room for args to cons.
	staq	ap|-2			store previous result
	ldaq	bp|0			get next most recent argument from bp
	staq	ap|-4			and make first arg to cons.
	eax7	4,x7			now call cons
	sprilp	ab|-4,x7			save lp
	stcd	ab|-2,x7		and return addr.
	tra	lisp_alloc_$cons_	and jump.

	lprpbp	ab|-2,x7			get back the ptr to args,
	ldx1	ab|-1,x7			and count.
	eppbp	bp|-2			move back one arg
	tra	lstfy_loop-*,ic		and loop if more args.

lstfy_end:
	eax7	-2,x7			pop off save space
	eppap	ap|-2			and argument
	tra	lisp_rtn_1-*,ic		and return.

	vfd	18/-1,18/fn_listify
qqlistify:
	ldaq	ab|nil
	staq	ap|-2
	ldaq	lisp_static_vars_$qlstfy
	tra	b_u_a_com


setarg:	eax2	qqsetarg-*,ic
	ldaq	ap|-4			move first arg up
	eppap	ap|2
	staq	ap|-2
	tsx5	argcom-*,ic
	ldaq	ap|-4			get 2nd arg
	staq	bp|0			store into stacked args
	eppap	ap|-6			clear stack
	tra	lisp_rtn_1-*,ic

" arg or setarg with no lexpr in process

bad_use_arg:
	eppap	ap|4
	ldaq	ap|-6
	staq	ap|-4
	tra	0,x2

	vfd	18/-1,18/fn_arg
qqarg:	ldaq	ab|nil
	staq	ap|-2
	ldaq	lisp_static_vars_$qarg
	tra	b_u_a_com-*,ic

	vfd	18/-1,18/fn_setarg
qqsetarg:	eppap	ap|2			this one has two args, have to make list of them
	ldaq	ap|-10			get 2nd arg to setarg
	staq	ap|-4
	ldaq	ab|nil
	staq	ap|-2
	tsx0	call_cons-*,ic
	ldaq	lisp_static_vars_$qsetarg
b_u_a_com:
	staq	ap|-6
	tsx0	call_cons-*,ic		make list of fcn-name and arg list
	eppap	ap|2
	ldaq	ab|nil
	staq	ap|-2
	tsx0	call_cons-*,ic
	tsx0	call_cons-*,ic
	lda	lisp_error_table_$no_lexpr
	tsx0	error-*,ic
	" never returns


call_cons:
	eax7	10,x7		save registers
	stx0	ab|-5,x7
	stx1	ab|-10,x7
	stx2	ab|-9,x7
	stx3	ab|-8,x7
	stx4	ab|-7,x7
	stx5	ab|-6,x7

	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	lisp_alloc_$cons_
	eppap	ap|2
	staq	ap|-2

	ldx1	ab|-6,x7
	ldx2	ab|-5,x7
	ldx3	ab|-4,x7
	ldx4	ab|-3,x7
	ldx5	ab|-2,x7
	ldx0	ab|-1,x7
	eax7	-6,x7
	tra	0,x0



"
" map functions

" written by D. Moon, 3 Aug 72

" the function being mapped is checked first (by find_type)
" to see what kind it is.  As much of the work of making
" binding_blocks, etc. as possible is done once only, instead
" of each time the function is called.  Then a quick loop is
" entered: the arguments are spread out on the pdl, and in the
" case of a fsubr or fexpr they are consed up again. The
" function is executed, the result it returns is taken care of,
" and the loop repeats.  When one (or more) of the map lists is
" exhausted, control passes to map_ending which cleans up and
" returns.  Note that becuase of this, if one of the map lists
" is initially nil (or atomic) the number-of-arguments
" checking may never get done.

" use of the marked pdl.
"
" there is some stuff peculiar to map, and above that
" the standard junk used by eval:
"
" bb|0,x3
"	mapfcn		function being mapped, as 
"			  returned by find_type
"	firstlist		first list being mapped over
"	   .
"	   .
"	   .
"	firstlist+2n-2	last list being mapped over
"(the above are initially the args to 'map', later
" cdr-ized or whatever)
"	mapresult		accumulates result of map.
"	form		as in apply
"	fcn		     "
"	argl		     "
"	qsrac		     "
"ap|0,x4
"	<possibly-empty binding block>
"
"	<args>		- pieces of the lists being mapped over
"ap|0


" use of the unmarked pdl
"	(much same as in apply)
"
"	save x3 and x5	(2 words, peculiar to map)
"	funarg binding block (2 words)
"	eval-frame	(2 words)
"	reg save area	(2 words)	- also handy non-gc temporaries
"	binding_block	(2 words)
"ab|0,x7

"
" register usage		- registers not listed are temp's
"
" x0	calling (tsx0)
" x2	control flags as in eval & apply
" x3	-> original args to map, on marked pdl
" x4	-size of binding block, as in eval & apply
" x5	number of lists being mapped over.
"	   ( = number of args to map-1)
" x7	unmarked pdl ptr (with ab)
" ap	marked pdl ptr
" bb	marked pdl base, used with x3 to get to mapfcn, map lists
" ab	unmarked pdl base


" define bits in x2 specifically for map

	bool	mapcarf,400000	mapc,mapcar,mapcan if 1
				"map,maplist,mapcon if 0
	bool	mapretf,200000	cons up list of return values
	bool	mapconf,100000	nconc up list of return values
	bool	listargs,40000	fsubr or fexpr
	bool	mapf,20000	so fcn_fin knows where to return to

"

	equ	mapfcn,0
	equ	firstlist,2
	equ	mapresult,form-2

"

	equ	mapsvx3,-10
	equ	mapsvx5,-9	PROBABLY NOT USED


	segdef	map,mapc,mapcar,maplist,mapcan,mapcon

"
" entry points	- just set x2 bits & enter common code

" these are type 1 lsubr's.
" the args property should be (2 . 777) or 777002

map:	eax2	applybit+mapf
	tra	mapcom-*,ic

mapc:	eax2	applybit+mapf+mapcarf
	tra	mapcom-*,ic

mapcar:	eax2	applybit+mapf+mapcarf+mapretf
	tra	mapcom-*,ic

maplist:	eax2	applybit+mapf+mapretf
	tra	mapcom-*,ic

mapcan:	eax2	applybit+mapf+mapcarf+mapconf
	tra	mapcom-*,ic

mapcon:	eax2	applybit+mapf+mapconf
	"tra	mapcom-*,ic

"
mapcom:	epbpbb	ap|0
	eax3	ap|0,x5		points to our args (lsubt)
	eaa	0,x5		get number of lists being  
	ars	19		 mapped over in x5
	neg	0
	eax5	-1,al

" if map or mapc, have to save first list so we can return it

	canx2	mapretf+mapconf,du
	tnz	mapc_klg_xx-*,ic			not map or mapc, skip it
	eppap	ap|2			sanwich in between map lists and mapresult,etc.
	ldaq	bb|firstlist,x3
	staq	ap|-2
mapc_klg_xx:
	eppap	ap|-mapresult	get room to work
	eax7	10,x7		..
	eax6	ap|0
	stx6	ab|-2,x7		binding_block.top_block
	sxl6	ab|-2,x7		binding_block.bot_block
	eax4	0		...binding block is empty (now)
	ldaq	ab|nil
	staq	ap|mapresult	init.
	ldaq	bb|mapfcn,x3
	staq	ap|form
	staq	ap|fcn		- as in apply
	stx3	ab|mapsvx3,x7	save ptr to our arguments

" in *rset t mode, make eval_frame

	ldaq	lisp_static_vars_$star_rset,*
	cmpaq	ab|nil
	tze	map_mnf-*,ic

	  eax6	  sp|1		apply-type frame
	  stx6	  ab|frame.dat1-6,x7
	  eax6	  ap|form		fcn being mapped
	  sxl6	  ab|frame.stack_ptr-6,x7
	  ldx6	  lisp_static_vars_$eval_frame+1
	  stx6	  ab|frame.prev_frame-6,x7
	  eax6	  ab|-6,x7
	  stx6	  lisp_static_vars_$eval_frame+1
	  orx2	  framebit,du

map_mnf:

	tsx3	find_type-*,ic	go analyze the fcn being mapped
" return transfer vector for find_type
	tra	map_subr-*,ic	array
	tra	map_subr-*,ic	subr
	tra	map_lsubr-*,ic
	tra	map_expr-*,ic
	tra	map_fexpr-*,ic
	tra	map_fsubr-*,ic
	tra	map_lexpr-*,ic

"
" set up various things on return from find_type
" called by tsx0

map_set_up:
	ldx3	ab|mapsvx3,x7	restore x3
	epbpbb	ap|0		base of marked pdl
	ldaq	ap|fcn,x4		save fcn for multiple applications
	staq	bb|mapfcn,x3
	eax1	ap|0			since mapped fcns never eval their args,
	tra	finish_bindings-*,ic	it is safe to make the pseudo bb a real bb now

"
" set up to map a fexpr

map_fexpr:
	tsx0	map_set_up-*,ic
	orx2	listargs+exprbit,du
	tsx0	lambda_bind-*,ic
	cmpx6	1,du		how many lambda variables?
	tnc	bad_fcnl-*,ic	 0 -- lose.
	tze	map_go-*,ic	 1 -- easy.
"				 2 -- bind 2nd to pdl ptr
	eaq	ab|-2,x7			make pdl ptr -> binding block
	qrl	18
	orq	-2,du
	lda	fixnum_type,dl
	staq	ap|-2,*
	tra	map_go-*,ic


" set up to map an expr -- or '(lambda ( ) ...)

map_expr:
	tsx0	map_set_up-*,ic
	orx2	exprbit,du
	tsx0	lambda_bind-*,ic
	stx5	ab|svx5u,x7
	cmpx6	ab|svx5u,x7	right number of args?
	tze	map_go-*,ic	yes.

	tsx6	make_argl-*,ic	no, give error
	tra	wrong_no_args_expr-*,ic




" set up to map a lexpr
" we can bind both the lambda atom and the argatom now,
" since we know how many args and where they will be.

map_lexpr:
	tsx0	map_set_up-*,ic
	orx2	exprbit+lsubrbit,du
	eppap	ap|8		going to bind two things
	eax4	-8,x4
	ldaq	ap|fcn,x4*	get the lambda - atom
	staq	ap|-2
	tsx0	ck_bound_var-*,ic
	ldaq	ap|-2,*
	staq	ap|-4
	eppbp	lisp_static_vars_$argatom
	spribp	ab|-4,x7		save area is not in use right now
	ldaq	ab|-4,x7
	ora	Uncollectable,dl	not really an atom
	staq	ap|-6
	ldaq	ap|-6,*
	staq	ap|-8
	eax1	ap|0
	stx1	ab|-2,x7		update binding_block.top_block

	eaq	ap|0		loc. of spread args
	eaa	0,x5		number of args
	ora	Uncollectable,dl
	staq	ap|-6,*		bind "argatom"
	lrl	54
	lda	fixnum_type,dl
	staq	ap|-2,*		bind lambda-atom
	tra	map_go-*,ic

"
" set up to map a subr - check number of args

map_subr:
	tsx0	map_set_up-*,ic
	cmpx5	ap|fcn,x4*	check number of args
	tze	map_go-*,ic	 ok.

	tsx6	make_argl-*,ic	no, error
	tra	wrong_no_args_subr-*,ic


" set up to map an fsubr - not hard

map_fsubr:
	tsx0	map_set_up-*,ic
	orx2	listargs,du
	tra	map_go-*,ic


" set up to map an lsubr - check number of args

map_lsubr:
	tsx0	map_set_up-*,ic
	orx2	lsubrbit,du
	ldaq	lisp_static_vars_$star_rset,*
	cmpaq	ab|nil		- only check # args in *rset t mode
	tze	map_go-*,ic

	lda	ap|fcn,x4*
	ana	=o000777,du	min
	sta	ab|-4,x7
	lda	ap|fcn,x4*
	ana	=o777000,du	max
	arl	9
	tnz	2,ic
	lda	=o777777,du	if max=0, use big number
	sta	ab|-3,x7
	cmpx5	ab|-4,x7
	tnc	map_tfa_lsubr-*,ic
	cmpx5	ab|-3,x7
	tze	map_go-*,ic
	tnc	map_go-*,ic
map_tma_lsubr:
	tsx6	make_argl-*,ic
	tra	too_many_args_lsubr-*,ic
map_tfa_lsubr:
	tsx6	make_argl-*,ic
	tra	too_few_args_lsubr-*,ic

"
" routine to put arguments up on top of marked pdl
" this is the map version of arg_spreader

" requires bb,x3 set up to get to map lists
" requires x5 to contain arg count
" updates x4
" uses x1,aq
" Doesn't change x6 or bb
" called by tsx0

mv_args:	eax1	bb|firstlist,x3
	eaa	0,x5		get number of lists times 2
	als	1
	sta	ab|svx5u,x7
	asx1	ab|svx5u,x7	used by cmpx1 to end the loop

mv_args_loop:
	cmpx1	ab|svx5u,x7	done all map lists?
	tze	0,0		  yes.
	ldaq	bb|0,x1		no, get one.
	cana	lisp_ptr.type,dl	end?
	tnz	map_ending-*,ic	  yes, go clean up
	canx2	mapcarf,du
	tze	2,ic
	ldaq	bb|0,x1*
	eppap	ap|2
	eax4	-2,x4
	staq	ap|-2		put an arg on pdl
	eax1	2,x1		..and advance to next list
	tra	mv_args_loop-*,ic

"
" routine to cons up an argument list
" used by fsubr, fexpr, and wrong_no_args

" called by tsx6 (yes 6, not 0)
" bb,x3 must be set up to get to map lists
" x5 must contain number of map lists
" uses x1
" destroys bb
" leaves x4, ap unchanged
" returns the argument list in ap|argl,x4

" this routine operates by calling mv_args to spread them out,
" then it pushes a nil on top of pdl to end the list,
" and calls cons enough times to bring them all down
" into a list.

" the entry point make_argl_nmv is for when mv_args
"  has already been called

make_argl:
	tsx0	mv_args-*,ic	first spread them out...
make_argl_nmv:
	eppap	ap|2		then put a nil at the end
	ldaq	ab|nil
	staq	ap|-2
	eax7	4,x7		-- extra save area
	stx5	ab|-1,x7
	adx4	ab|-1,x7		adjust x4 back to what it should be,
	adx4	ab|-1,x7		after all the consing is done
	stx6	ab|-2,x7		save our return addr

	tsx0	call_cons-*,ic	-- known to be at least 1 arg
	sbx5	1,du
	tnz	-2,ic

	ldx6	ab|-2,x7
	ldx5	ab|-1,x7
	"ldaq	ap|-2
	eppap	ap|-2
	eax7	-4,x7
	staq	ap|argl,x4
	tra	0,6
"
" here we have the routine to actually apply the function

map_go3:	ldx3	ab|mapsvx3,x7	restore x3 after function call

map_go:	epbpbb	ap|0		bb may have been munged
	tsx0	mv_args-*,ic	spread out the args
	ldaq	bb|mapfcn,x3	get the fcn
	staq	ap|fcn,x4		where eval wants it
	canx2	exprbit,du	expr type or subr type?
	tnz	map_do_expr-*,ic

" subr type

	canx2	listargs,du	fsubr?
	tnz	map_do_fsubr-*,ic	 yes.
	canx2	lsubrbit,du	lsubr?
	tze	call_subroutine-*,ic   no, subr is simple
	eaa	0,x5		yes, make argcount
	als	1
	neg	0
	eax6	0,au
	tra	call_subroutine-*,ic


map_do_fsubr:
	tsx6	make_argl_nmv-*,ic
	ldaq	ap|argl,x4
	eppap	ap|2		pass arg list on top of marked pdl
	eax4	-2,x4
	staq	ap|-2
	tra	call_subroutine-*,ic



" expr type

map_do_expr:
	canx2	listargs,du	fexpr?
	tnz	map_do_fexpr-*,ic	 yes.

" do any necc bindings then go to eval_lambda_body

	canx2	lsubrbit,du	lexpr?
	tnz	map_do_lexpr-*,ic	    yes - go reassign nargs to lambda atom

" bind lambda variables for expr - args are on marked pdl


	ldaq	ap|fcn,x4*	= lambda list
	ldx1	ab|-2,x7		binding_block.top_block = base of args
map_expr_bind_loop:
	cana	lisp_ptr.type,dl	end?
	tnz	map_expr_bind_end-*,ic   yes...
	staq	ap|qsrac,x4	no.
	epplb	ap|qsrac,x4*
	ldaq	bb|0,x1		get an arg
	staq	lb|0,*		assign a var
	eax1	2,x1
	ldaq	lb|2
	tra	map_expr_bind_loop-*,ic

map_expr_bind_end:
	ldx1	ab|-2,x7		remove spread args from pdl
	eppap	bb|0,x1
	lxl4	ab|-2,x7		reset x4
	sbx4	ab|-2,x7
	tra	eval_lambda_body-*,ic


" bind 1 lambda variable of fexpr

map_do_fexpr:
	tsx6	make_argl_nmv-*,ic
	eppbp	ap|fcn,x4*	cons lambdalist body
	eppbp	bp|0,*		cons firstlambdavar restoflambdalist
	ldaq	ap|argl,x4	get argument list
	staq	bp|0,*		assign it to first lambda-var
	tra	eval_lambda_body-*,ic

" for a lexpr, reset the lambda atom to the number of args
" each time in case loser clobbers it:
"  (map '(lambda y (setq y 'foo)) '(1 23) '(4  5))

map_do_lexpr:

	eaq	0,x5			get nargs
	qrl	18
	lda	fixnum_type,dl		convert to lisp-number
	eppbp	ap|fcn,x4*		-> atom_ptr -> atom.value
	staq	bp|0,*			store into atom's value cell
	tra	eval_lambda_body-*,ic	now go eval fcn
"
" come here after one evaluation by map
" causes cleanup, resultmunging, and around again going
" NB: x3 doesn't get restored until we go back to map_go3

map_fcn_fin:
	ldx1	ab|-2,x7		remove spread args from pdl if still there
	epbpbb	ap|0		 (lexpr)
	eppap	bb|0,x1
	lxl4	ab|-2,x7		reset x4
	sbx4	ab|-2,x7
"" Now (after calling the fcn) cdr-ize all the lists
"   at this point we assume x5 has arg count and x3 can be loaded to point at lists
	ldx3	ab|mapsvx3,x7
	eax1	bb|firstlist,x3
	eax6	0,x5		x1 -> list, x6 = counter
	tze	map_cdr_loop_end-*,ic
map_cdr_loop:
	eppbp	bb|0,x1*		-> cons whose car has been done.
	ldaq	bp|2		cdr of that cons
	staq	bb|0,x1
	eax1	2,x1
	eax6	-1,x6		count the lists
	tnz	map_cdr_loop-*,ic
map_cdr_loop_end:
	canx2	mapretf,du
	tnz	map_ret_er-*,ic
	canx2	mapconf,du
	tnz	map_con_er-*,ic
	tra	map_go3-*,ic	-- go around again

map_ret_er:
	eax1	map_go3
	eppap	ap|4
	ldaq	ap|qsrac-4,x4	current result
	staq	ap|-4
	ldaq	ap|mapresult-4,x4	last cons in list of previous results, cdr = first cons
	cmpaq	ab|nil		first time?
	tze	map_ret_1st-*,ic
	eppbp	ap|mapresult-4,x4*	no, get cdr
	ldaq	bp|2
	staq	ap|-2
	tsx0	call_cons-*,ic
	ldaq	ap|-2
	eppbp	ap|mapresult-2,x4*
	staq	bp|2
	staq	ap|mapresult-2,x4
	eppap	ap|-2
	tra	0,x1

map_ret_1st:
	staq	ap|-2
	tsx0	call_cons-*,ic
	ldaq	ap|-2
	eppap	ap|-2
	staq	ap|mapresult,x4
	eppbp	ap|mapresult,x4*
	staq	bp|2		set cdr back to start of list
	tra	0,x1
"
map_con_er:
	eax0	map_go3

	ldaq	ap|mapresult,x4
	eppap	ap|4
	staq	ap|-4
	ldaq	ap|qsrac-4,x4
	staq	ap|-2
	eax7	6,x7		get space to save regs, make call.
	stx2	ab|-6,x7		store registers we still need
	stx5	ab|-5,x7		save x5, since we will clobber it.
	sxl0	ab|-5,x7		save x0, our return ptr
	sxl4	ab|-6,x7		also save x4.
	eax5	-4		nconc gets 2 args, lsubr convention.
	sprilp	ab|-4,x7		save our lp...
	stcd	ab|-2,x7		save return address.
	tra	lisp_alloc_$nconc
	ldx2	ab|-2,x7		reload registers.
	ldx5	ab|-1,x7
	lxl0	ab|-1,x7
	lxl4	ab|-2,x7
	eax7	-2,x7		and pop off stack
	staq	ap|mapresult,x4	save result of nconc.
	tra	0,0

" come here when freturn returns from a function being mapped
" have to re-establish binding block, & c.
" and restart the mapping process all over again.

map_freturn:
	eax4	0		the binding block is all gone
	canx2	mapretf,du
	tnz	map_ret_er_freturn
	canx2	mapconf,du
				" and fall into map_freturn_restart
map_freturn_restart:

" re-make binding block

	eax6	ap|0
	stx6	ab|-2,x7
	sxl6	ab|-2,x7
	ldaq	ap|form			the fcn being mapped
	staq	ap|fcn			put it back
	tra	map_mnf

map_ret_er_freturn:
	eax1	map_freturn_restart
	tra	map_ret_er+1
map_con_er_freturn:
	eax0	map_freturn_restart
	tra	map_con_er+1
	tra	map_freturn_restart"
"
"come here when map is done.

map_ending:		" first get the result into proper form

	canx2	mapretf,du
	tze	map_ending_aa-*,ic
	ldaq	ap|mapresult,x4		check for nil
	cmpaq	ab|nil
	tze	map_ending_2-*,ic		nil => don't rplacd
	eppbp	ap|mapresult,x4*		mapcar, uncircularize return list
	ldaq	bp|2
	staq	ap|qsrac,x4
	ldaq	ab|nil			- put nil at end of list
	staq	bp|2
	ldaq	ap|qsrac,x4		get back ptr to start of list
	tra	map_ending_2-*,ic

map_ending_aa:
	canx2	mapconf,du
	tnz	map_ending_1-*,ic		mapresult already ok if mapconf

" map or mapc, return first map list as result

	ldaq	ap|mapresult-2,x4		was saved here on entry
	tra	map_ending_2-*,ic

map_abending:
map_ending_2:
	staq	ap|mapresult,x4

map_ending_1:
	ldx3	ab|mapsvx3,x7		get back x3
	tsx0	unbinder-*,ic
	eax7	-2,x7			pop map's extra 2 words
	ldaq	ap|mapresult		= out return value
	awdx	ap|0,x3			clear rest of marked pdl
	tra	lisp_rtn_1-*,ic



" routine to evaluate the bodies of prog's and do's
" called with a pointer to the stack cell containing the
" body of the prog or do on top of unmarked pdl.  Pops it off,
" evaluates the nonatomic elements of the body, ignoring the
" values, and returns when it gets to the end.

	entry	eval_list

eval_list: tsx0	pl1_entry-*,ic
	eppap	ap|10			room to eval in
	eppbp	ab|-2,x7*			-> stack temp containing body
	eax7	-2,x7
	eppbp	bp|-2			look like a cons

" cdr-ize the list and eval next element

ev_list_1:
	ldaq	bp|2			is cdr atomic?
	cana	lisp_ptr.type,dl		..
	tnz	ev_list_end-*,ic		 yes.
	eppbp	bp|2,*			no, point bp at cdr
	spribp	ap|-10			and save it (no type bits since is list)
	ldaq	bp|0			get cadd...ddr of body
	cana	lisp_ptr.type,dl
	tnz	ev_list_2-*,ic		skip over it if it is atomic
	staq	ap|form			otherwise, evaluate it
	tsx5	eval_fcn-*,ic
ev_list_2:
	eppbp	ap|-10,*			get back a ptr to current cons of list
	tra	ev_list_1-*,ic		and go eval next elem

ev_list_end:
	eppap	ap|-4			clear the pdl
	tra	pl1_return-*,ic		and return.

" the return function, a type 1 subr

	segdef	return
return:	eppap	ap|2			put 2 things at top of pdl:
	lda	Uncollectable,dl		 1) the return value
	staq	ap|-2			 2) a non_nil value to distinguish from go
	tra	go_ret-*,ic		and return to prog


" the go function, a type 1 fsubr

	segdef	go
go:	ldaq	ap|-2,*			get our arg
	eppap	ap|6			room to eval in

" keep evaling the arg until it is atomic

re_go:	cana	lisp_ptr.type,dl
	tnz	go_1-*,ic
	staq	ap|form
	tsx5	eval_fcn-*,ic
	tra	re_go-*,ic

go_1:	staq	ap|form			save label on marked pdl for prog
	ldaq	ab|nil			and put nil to mark this as a go
	staq	ap|form+2
	eppap	ap|form+4

go_ret:	" now do a non-local goto to the most recent prog (or do)

	ldx1	lisp_static_vars_$prog_frame+1
	tze	bad_go-*,ic		err if no prog active

" prog is a pl1 program, so return to pl1_code mode

	spriap	ab|stack_ptr_ptr,*
	stx7	ab|unmkd_ptr_ptr,*
	stc1	ab|in_pl1_code

	eax2	sp|0			are we in same stack frame as prog?
	cmpx2	ab|frame.ret+3,x1		 (this is the usual case)
	tze	go_ret_same_sp-*,ic		yes, go without changing sp

	" check if there possibly could be cleanup handlers in the stack

	cmpx1	lisp_static_vars_$err_recp+1
	tnc	go_ret_full_unwind		might be cleanup handlers, have to go call unwinder_
	eppbp	ab|frame.ret+2,x1*		no, get ptr to stack frame of prog
	spribp	sp|16			delete intervening frames. (allowed since
					 " there are no cleanup handlers in lisp)
	eax2	bp|0
	eppbp	ab|frame.ret,x1*		get return address
	spribp	sb|20,x2			set call out return addr in prog's frame
	return				" quickly return to prog

go_ret_same_sp:
	eppbp	ab|frame.ret,x1*
	spribp	sp|20
	short_return

" come here when go or return is done with no prog active

bad_go:	lda	lisp_error_table_$bad_prog_op
	tsx0	error-*,ic
	arg	0			uncorrectable fail-act, should never return


" have to do the go by calling unwinder.

go_ret_full_unwind:
	push			"must save ab, x1 - get ready to call unwinder_
	tempd	Argl(2)		arg list of one arg

	ldaq	arg_list_1_hdr
	staq	Argl
	eppbp	ab|frame.ret,x1	-> label to return to
	spribp	Argl+2
	eppap	Argl
	short_call  unwinder_$unwinder_


	even
arg_list_1_hdr:
	zero	2,4
	zero	0,0

negative_4:
	zero	0,fixnum_type
	dec	-4

" come here to call a function with unevaluated arguments from
" lisp-compiled code.  ap|form=ap|fcn=function, ap|argl = arg list,
" unmkd pdl has: ptr to link, caller's lp, return addr(bp)

" we find the type of the function and if its an fsubr link directly
" to it, otherwise go through regular apply.

	segdef	callf

callf:
	eax2	applybit
	eax5	callf_rtn-*,ic
	tsx3	evaler1-*,ic
" return transfer vector for find_type

	tra	eval_subrs_and_arrays-*,ic		array
	tra	eval_subrs_and_arrays-*,ic		subr
	tra	eval_lsubr-*,ic			lsubr
	tra	eval_expr-*,ic			expr
	tra	eval_fexpr-*,ic			fexpr
	tra	callf_fsubr-*,ic			fsubr - special case
	tra	eval_lexpr-*,ic			lexpr



" callf to an fsubr -- attempt to direct-link it

callf_fsubr:
	tsx0	snappable_p-*,ic	snappable?
	tra	eval_fsubr-*,ic		 no.
					" yes, so do it.
	ldaq	ap|fcn,x4				get subr ptr
	adq	1,du				place to tspbp to
	stz	lisp_static_vars_$no_snapped_links
	eppbb	ab|-12,x7*			caller's lp
	eax0	-1
	ansx0	bb|-6				clear low half - clears no snapped links bit
	staq	ab|-14,x7*			store over link
	tsx0	unbinder-*,ic			get rid of binding block, eval frame
	ldaq	ap|argl				put argl back where it was when we were called
	staq	ap|form
	eppap	ap|form+2
	epplp	ab|-4,x7*				restore caller's lp
	eppbp	ab|-2,x7*
	eax7	-6,x7				pop off our temps
	tra	bp|-1				return to the tspbp which now goes
						" direct to the subr

 
" come here when done with a callf. This routine packs up and goes home.

callf_rtn:
	eppap	ap|form
	epplp	ab|-4,x7*
	eppbp	ab|-2,x7*
	eax7	-6,x7
	tra	bp|0				return with result in aq

" routine to apply subr's to arguments which are already separated by lisp code.

	entry	pl1_callable_funcall_
pl1_callable_funcall_:
	tsx0	pl1_entry		Establish ALM environment
	lxl5	ap|-1		Get # of args
	eppap	ap|-2		Pop arg count
	tsx0	funcall0
	eppap	lp|2		Pop stack, leave ret loc.
	staq	ap|-2
	getlp	
	tra	pl1_exit

	segdef	funcall
funcall:	tsx0	funcall0
	eppap	lp|0		pop stack
	tra	lisp_rtn_1	and return to caller

funcall0: eax5	2,x5
	tpnz	fc_0_args
	eppap	ap|-form
	ldaq	ap|form-2,x5
	staq	ap|form
	staq	ap|fcn
	eax2	applybit+already_spread+entered_by_funcall
	eax7	6,x7
	ldaq	negative_4	for causing fault if used!
	staq	ab|-6,x7
	eppbp	ap|form-2,x5	we want to sve location to which to pop
	spribp	ab|-4,x7		which will come back in lp
	eppbp	0,x0		Set exit
	spribp	ab|-2,x7
	tra	fc_join


fc_0_args:
	drl	0

""" fsubr's arraycall, subrcall, lsubrcall.

	segdef	arraycall,subrcall,lsubrcall

subrcall:	tsx4	foocall-*,ic
	tra	subrcall_error-*,ic
	lda	ap|fcn,*		make sure it really is a subr.
	cana	=o777000,du
	tnz	subrcall_error-*,ic	looks more like an lsubr, barf.
	tra	evaler-*,ic	OK, go apply it.

lsubrcall:tsx4	foocall-*,ic
	tra	lsubrcall_error-*,ic
	lda	ap|fcn,*		make sure it really is an lsubr
	cana	=o777000,du
	tze	lsubrcall_error-*,ic	looks more like a subr.
	orx2	lsubrbit,du
	tra	evaler-*,ic	OK, go apply it.

arraycall:eppap	ap|2
	ldaq	ap|-4
	staq	ap|-2
	ldaq	ap|-2,*		get car of arglist, which is type
	staq	ap|-4		save it.
	tsx4	foocall-*,ic
	tra	arraycall_error-*,ic
	cana	Array,dl		make sure it really is an array.
	tze	arraycall_error-*,ic   no, barf.
	eppbp	ap|fcn,*		pick up array pointer
	ldx0	bp|7		pick up type off array
	ldaq	ap|form-2		pick up type in other form
	xec	array_test,x0	see if it is right type
	tnz	arraycall_mismatch-*,ic	type mismatch, loser.
	tsx5	evaler-*,ic	OK, go call the array.
	eppap	ap|form-2		clear all stuff from stack
	tra	lisp_rtn_1-*,ic

array_test:
	cmpaq	lisp_static_vars_$t_atom
	cmpaq	lisp_static_vars_$nil
	cmpaq	lisp_static_vars_$fixnum
	cmpaq	lisp_static_vars_$flonum
	cmpaq	lisp_static_vars_$readtable
	cmpaq	lisp_static_vars_$obarray
	tra	arraycall_mismatch

foocall:	eppap	ap|-form-2
	eppbp	ap|form,*		-> arg list
	eppbp	bp|2,*		discard the type.
	eax2	applybit		no form available, but arguments are to be evaluated.
	ldaq	bp|0		get the alleged subr pointer.
	staq	ap|-2		which has to be evaluated
	ldaq	bp|2		get list of arguments to be passed
	staq	ap|argl
	eax7	8,x7
	tsx0	recurse-*,ic	evaluate the subr pointer
	eax7	-8,x7
	staq	ap|form		and put it away
	staq	ap|fcn
	cana	Subr,dl		is it at least a subr pointer?
	tze	0,x4		no, couldn't possibly win
	eax5	lisp_retn-*,ic	set exit going to use.
	tra	1,x4

" come here to call a function with already evaluated arguments from
" lisp - compiled code.  ap|form = fcn, x5 = -2*nargs, unmkd pdl
" has: ptr to link, caller's lp, return addr (bp)
" underneath ap|form on the marked pdl we have the args

" we first call find_type and then if possible
" change the link to point directly to the function, otherwise
" call it in the usual way and then return the result.

	segdef	call1

call1:
	eax2	applybit+already_spread
	ldaq	ap|form
	staq	ap|fcn				needs to be in both places

" set ap|argl to an Uncollectable object containing 
" nargs in qu and -2*nargs in ql and ptr to args in au
" the already_spread bit in x2 indicates that this is not an argl

fc_join:			"funcall joins here.
	eaa	0,x5
	ars	19
	neg	0				al has nargs
	eaq	0,x5
	lrl	18				qu has nargs, ql has -2*nargs
	eaa	ap|form,x5		 	ptr to args
	ora	Uncollectable,dl
	staq	ap|argl
	eax5	call1_rtn-*,ic			where to come back to after applying
	tsx3	evaler1-*,ic			go to find_type
" return transfer vector for find_type
	tra	cc_subr-*,ic			array
	tra	cc_subr-*,ic			subr
	tra	cc_lsubr-*,ic			lsubr
	tra	eval_expr-*,ic			expr - same as usual
	tra	call1_fexpr_check-*,ic			fexpr - lose, args already evaled
	tra	call1_fsubr_check-*,ic			fsubr - lose, args already evaled
	tra	eval_lexpr-*,ic			lexpr - same as usual



call1_fexpr_check:
	eax0	eval_fexpr
fc_f_fcn_check:
	canx2 	entered_by_funcall,du
	tze	illegal_f_fcn
	ldx3	ap|argl+1,x4		check n args
	cmpx3	1,du
	tpnz	too_many_args_subr
	tmi	too_few_args_subr
	ldaq	ap|form-2,x4
	staq	ap|argl,x4
	tra	0,x0

call1_fsubr_check:
	tsx0	fc_f_fcn_check
	tra	eval_fsubr


" routines for lsubr's and subr's which check to see if direct linking can
" be used.  If so they change the link and then return to the tspbp,
" otherwise they go through the regular cruft

cc_lsubr:	orx2	lsubrbit,du
	canx2	entered_by_funcall,du
	tnz	eval_lsubr
	lda	ab|-14,x7*			get first word of link
	ana	=o77700,dl
	cmpa	=o77700,dl			was x5 loaded by caller?
	tnz	eval_lsubr-*,ic			if not, must interpret call.


cc_subr:
	tsx0	snappable_p-*,ic		snappable?
	tra	cant_snap-*,ic		 no.
					" yes, so do it.


" seems to be snappable, check the number of args

	ldx3	ap|argl+1			get number of args called with
	canx2	lsubrbit,du
	tnz	cc_lsubr_ckna-*,ic
	cmpx3	ap|fcn,*
	tze	3,ic
	tnc	too_few_args_subr-*,ic
	trc	too_many_args_subr-*,ic
cc_lsubr_ck_ret:

" snappable, so change the link to point directly at the function instead of at us

	ldaq	ap|fcn,x4			get subr ptr
	adq	1,du			-> place to tspbp to
	stz	lisp_static_vars_$no_snapped_links
	eppbb	ab|-12,x7*		caller's lp
	staq	ab|-14,x7*		store over link
	eaa	-1			now clear his no snapped links bit
	ansa	bb|-6
can_snap:	tsx0	unbinder-*,ic		get rid of binding block, eval frame
	lxl5	ap|argl+1			get back caller's x5
	eppap	ap|form			set ap back to caller">'s value
	epplp	ab|-4,x7*			restore caller's lp
	eppbp	ab|-2,x7*
	eax7	-6,x7			set x7 back to caller's value
	tra	bp|-1			return to the tspbp, which now goes
					" direct to the subr.

" unspappable, do it the regular way

cant_snap:
	canx2	lsubrbit,du
	tnz	eval_lsubr-*,ic
	tra	eval_subrs_and_arrays-*,ic

cc_lsubr_ckna:
	tsx0	ck_lsubr_nargs-*,ic
	tra	cc_lsubr_ck_ret-*,ic
" 
" routine to see if this call can be snapped, i.e. if the
" itb link through which we were called can be changed
" to point directly at the function.
" called by tsx0, skip return if snappable

snappable_p:
	canx2	entered_by_funcall+went_through_value_cell,du
	tnz	0,0
	cmpx4	0,du
	tnz	0,0
	lxl6	ab|-14,x7*		test snap bit in calling link
	tpl	0,0
	ldaq	lisp_static_vars_$nouuo_flag,*
	cmpaq	ab|nil
	tnz	0,0			suppressed by user
	tra	1,0		        - can snap, skip return.


" the lisp nouuo function, which is a type 1 subr of one arg
" If the arg is nil, snapping is allowed. If anything else (t),
" snapping is disallowed.

	segdef	nouuo

nouuo:	ldaq	ap|-2			get arg
	eppap	ap|-2
	cmpaq	ab|nil			is it nil?
	tze	2,ic
	ldaq	ab|true			no, assume t.
	staq	lisp_static_vars_$nouuo_flag,*
	tra	lisp_rtn_1-*,ic
 
" come here when done evaling from a call1

call1_rtn:
	lxl5	ap|argl+1
	eppap	ap|form,x5
call1_rtn_1:
	epplp	ab|-4,x7*
	eppbp	ab|-2,x7*
	eax7	-6,x7
	tra	bp|0				return with result in aq
"

"  snapcaller -- entry for pl1 subrs with function args that are
"		called repeatedly to use for applying the
"		function arg to its arguments.  It acts
"		quite similarly to callf and call1, since
"		it takes a function to be called, and replaces
"		that function with a pointer to the subroutine
"		entry if the number args match.
"
"		called with ab|-2,x7 containing offset of
"		function from stack top, and ab|-1,x7
"		containing -2*nargs, and with the arguments
"		on the top of the marked pdl.

" Last modified by D Reed, 7/7/73


	entry	snapcaller
snapcaller:
	tsx0	pl1_entry
	lxl0	ab|-2,x7		get offset of fcn from stack top
	lxl5	ab|-1,x7		and -2*nargs into x5.
	ldaq	ap|0,x0		load function
	cana	Subr,dl		if function is a subr object
	tze	chk_snapper
	canq	1,du		and points at odd address,
	tze	chk_snapper
call_snapped:
	tspbp	ap|0,x0*		call the subr.
	eppap	ap|2		get room to return result
	staq	ap|-2		and do it.
	tra	pl1_exit		return to caller

chk_snapper:
	eax2	applybit+already_spread
	eppap	ap|-form		get save area
	staq	ap|form		and initialize it
	staq	ap|fcn
	eaa	0,x5		put special object in ap|argl
	neg	0
	ars	19
	eaq	0,x5
	lrl	18
	eaa	ap|form,x5		address of args.
	ora	Uncollectable,dl
	staq	ap|argl		...

	eax5	snapcall_rtn-*,ic	set return for snapcall resulting in apply
	tsx3	evaler1
	tra	sn_subr
	tra	sn_subr		subrs and arrays
	tra	sn_lsubr
	tra	eval_expr
	tra	illegal_f_fcn	bad function
	tra	illegal_f_fcn
	tra	eval_lexpr	interpret lexpr

sn_lsubr:	orx2	lsubrbit,du	note that lsubr is slightly different.
sn_subr:	canx2	went_through_value_cell,du	check for snappability.
	tnz	sn_cant
	cmpx4	0,du		if bindings made, cant dnap
	tnz	sn_cant
	ldx3	ap|argl+1		get number of args
	canx2	lsubrbit,du
	tnz	sn_lsubr_ckna
	cmpx3	ap|fcn,*		(check number of args, note x4 = 0)
	tze	3,ic
	tnc	too_few_args_subr-*,ic
	tra	too_many_args_subr-*,ic
sn_lsubr_chk_ret:
	tsx0	unbinder-*,ic	get rid of junk
	lxl5	ap|argl+1		reload x5 for call
	lxl0	ab|-2,x7	reload offset of function
	ldaq	ap|fcn
	adq	1,du		make address odd.
	staq	ap|form,x0		snap link
	eppap	ap|form
	tra	call_snapped	and do the call

sn_lsubr_ckna:
	tsx0	ck_lsubr_nargs
	tra	sn_lsubr_chk_ret

sn_cant:	canx2	lsubrbit,du	if cant snap, then apply function
	tnz	eval_lsubr
	tra	eval_subrs_and_arrays

snapcall_rtn:
	lxl5	ap|argl+1
	eppap	ap|form+2,x5	get place to store argument
	staq	ap|-2
	tra	pl1_exit



	include	stack_header
	end




		    lisp_alloc_.alm                 11/05/86  1612.7r w 11/04/86  1039.1      305631



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
	name	lisp_alloc_	" lisp allocator.

	use	static		" static variables.
	join	/link/static

	segdef	alloc_info
alloc_info:
	segdef	alloc_fault_word
alloc_fault_word:
	dec	0		" this word is non-zero to indicate that interrupts
				" must be masked temporarily, while data is inconsistent.
				" upper half is set to non-zero, lower two bits recor
				" quit and alarm faults as they happen, for later signalling.

	segdef	gc_blk_cntr
gc_blk_cntr:
	dec	0		" this word counts the number of blocks to garbage collection.
				" if negative, that many more 16K blocks will be allocated.
	segdef	seg_blk_cntr
seg_blk_cntr:
	dec	0		" this word counts the number of blocks left before the
				" end of the current segment.
	even
	segdef	consptr
consptr:	its	-1,1,ad		" this pointer points at the segment's ad indirect word.

	segdef	cur_seg
cur_seg:	its	-1,1		" this pointer points at the current segment's base.

"
	use	program
	join	/text/program

" subroutines to go from lisp calling discipline to PL/I and back.
"

	tempd	arglist(4),new_seg_ptr

	even
noargs:
	oct	4
	oct	0
header_for_1_arg:
	oct	2000004		" pl1 arg header, 1 argument.
	oct	0

save_for_pl1_call:			" routine to switch to PL/I conventions, and get a stack
				" frame to call out from.

	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code	" remember we are using these conventions now.
	push
	eppbp	<lisp_alloc_>|[lisp_alloc_]	set entry pointer
	spribp	sp|stack_frame.entry_ptr
	tra	0,x6		" return. x6 is not used by save macro.

pop_back_to_lisp:			" routine to get rid of stack frame, 
				" and re-enter lisp code.
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sp|16,*		" get back to prev stack frame.
switch_to_lisp:			" alternate entry for entering lisp conventions.
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	tra	0,x6		" return to caller.


"
"	Subroutine to allocate 4 words for a cons. called with a tsx6.

cons_alloc:
	stc1	lp|alloc_fault_word		" inhibit interrupts.
	eppbp	lp|consptr,*		" use pointer with ad modifier to do work.
	ttn	tally_out

ret_alloc:
	ldac	lp|alloc_fault_word
	ana	=o7,dl			" mask out low order bits.
	tze	0,x6			" return if no interrupts.

"
"	code to handle faults in alloc here.
"
alloc_got_fault:				" operators for allocation join here after saving other things.
	eax7	4,x7			" get space to save useful regs.
	spribp	ab|-4,x7			" bp points to space we just allocated.
	sta	ab|-2,x7			" a contains argument for fault decoding.
	stx6	ab|-1,x7			" x6 contains eventual return address.
	sxl5	ab|-1,x7
	tsx6	save_for_pl1_call-*,ic	" save, and switch to pl1 conventions.
	eppbp	<lisp_static_vars_>|[unmkd_ptr],*
	eppbp	bp|-2			" get address of saved fault bits.
	spribp	arglist+2			" and set as first arg to handler
	ldaq	header_for_1_arg-*,ic	" get arglist header for 1 arg.
	staq	arglist
	eppap	arglist
	short_call <lisp_default_handler_>|[alloc_fault]
	tsx6	pop_back_to_lisp-*,ic	" remove stack frame, and reload ap,ab,x7.
	ldx6	ab|-1,x7			" reload return address.
	lxl5	ab|-1,x7			"reload saved x5.
	eppbp	ab|-4,x7*			" reload pointer to space allocated.
	eax7	-4,x7
	tra	0,x6





tally_out:
	aos	lp|gc_blk_cntr		" one less block remains till gc.
	tmi	2,ic			" if more before gc, continue.
	tsx4	must_gc-*,ic		" if no more, go gc.
	aos	lp|seg_blk_cntr		" one less block in segment, too.
	tze	get_new_seg-*,ic		" get new segment if needed.

				" otherwise, check for interrupt, and return.
	tra	ret_alloc
"
" 	Subroutine to allocate words (multiple of 4) in q. Called with tsx6.

	segdef	words_alloc
words_alloc:
	stc1	lp|alloc_fault_word		" inhibit interrupts.
	eax0	-4,ql			" number of words to allocate.
	eppbp	lp|consptr,*		" let the ad modifier do the work.
					" if no tally out, keep going.
	ttn	tally_done-*,ic		" otherwise, end of core block.

alloc_loop:
	eax0	-4,x0			" 4 more words gotten by ad modifier,
	tmi	ret_alloc-*,ic		" if no more, then we can return!
	eax1	lp|consptr,*		" ad modifier gets more space, as side effect.
	ttf	alloc_loop-*,ic		" and if not at end of block, keep going.

tally_done:
	aos	lp|gc_blk_cntr		" reduce number of blocks before next gc.
	tmi	2,ic			" if more before gc, continue.
	tsx4	must_gc-*,ic		" if no more, garbage collect now.
	aos	lp|seg_blk_cntr		" reduce number of blocks to seg end.
	tmi	alloc_loop-*,ic		" if still more in segment, just continue.
	tra	get_new_seg-*,ic

locked_alloc:		" routine to alloc words when already locked, and no gc allowed
	eax1	*+2	"simulate stc1 effect.
	stx1	lp|alloc_fault_word
	eax0	-4,ql
	eppbp	lp|consptr,*
	ttn	lock_tally_done
lock_alloc_loop:
	eax0	-4,x0
	tmi	0,x6
	eax1	lp|consptr,*
	ttf	lock_alloc_loop

lock_tally_done:
	aos	lp|gc_blk_cntr		" caller's responsibility to check gc_blk_cntr.
	aos	lp|seg_blk_cntr
	tmi	lock_alloc_loop
	tra	get_new_seg
"
"	Subroutine to get a new allocation segment. lp|alloc_fault_word is set,
"	so a ret instruction will go back and redo allocation.

get_new_seg:
	eax7	2,x7			" get room for save of caller's return address
	stx6	ab|-2,x7
	sxl5	ab|-2,x7			" save x5 for lsubr callers.
	stq	ab|-1,x7			" and num words to allocate.
	tsx6	save_for_pl1_call-*,ic	" go to PL/I calling conventions.
	eppbp	new_seg_ptr		" get address of pointer arg.
	spribp	arglist+2
	ldaq	header_for_1_arg-*,ic
	staq	arglist
	call 	<lisp_segment_manager_>|[get_lists](arglist)
	ldaq	lp|cur_seg		" get cur segment ptr
	eppbp	new_seg_ptr,*		" get pointer to new seg base.
	staq	bp|0			" thread in old segment.
	spribp	lp|cur_seg		" and make new segment the current segment.
	eppbp	bp|2			" get pointer to ad tally word.
	spribp	lp|consptr		" store it away.
	lda	=o53,dl			" load ad modifier value
	orsa	lp|consptr+1		" and put in the further modification 
					" part of its pointer.
	lda	=o4740004			" load actual tally word initial value
	sta	bp|0			" and store it in segment's tally word.
	lca	16,dl			" load minus number of 16K blocks in segment.
	sta	lp|seg_blk_cntr		" so the end of segment will be caught.
	tsx6	pop_back_to_lisp-*,ic
	ldq	ab|-1,x7			" reload saved registers.
	ldx6	ab|-2,x7
	lxl5	ab|-2,x7			" reload x5 for lsubr callers.
	eax7	-2,x7			" pop back unmarked stack,
	ldx0	lp|alloc_fault_word	" and return to restart point of allocation routine.
	tra	0,x0
"
"	Subroutine which calls the garbage collector, and reinitializes data
"	before restarting allocation again.
"	called with a tsx4, returns to just after tsx4 if gc inhibited, otherwise,
"	returns to restart address in alloc_fault_word, as old allocation meaningless.
"

must_gc:
	szn	<lisp_static_vars_>|[garbage_collect_inhibit]
	tnz	0,x4			" return if gc inhibited, and don't gc until next block done.
					" and don't gc till next block done.
	eax7	2,x7			" get space to save registers.
	stx6	ab|-2,x7
	sxl5	ab|-2,x7			" save x5 for lsubr callers
	stq	ab|-1,x7
	tsx6	save_for_pl1_call-*,ic
	eppap	noargs-*,ic
	short_call <lisp_garbage_collector_>|[lisp_garbage_collector_]
	tsx6	pop_back_to_lisp-*,ic
	ldq	ab|-1,x7			" reload saved registers.
	ldx6	ab|-2,x7			" ..
	lxl5	ab|-2,x7
	eax7	-2,x7
	ldx0	lp|alloc_fault_word		" restart allocation again.
	tra	0,x0
"
"operators for compiled code to allocate conses.
" by using these operators, compiled code is made more compact
" and locally more efficient.

	segdef	cons_opr
cons_opr:	tsx6	opr_cons
cons_opr_com0:
	staq	bb|0		store aq into car of allocated cons
cons_opr_com1:
	tsx6	opr_ck_fault	check for faults in cons
	ldaq	bb|0		reload aq from car
	tra	bp|0		return to caller

	segdef	ncons_opr
ncons_opr:tsx6	opr_cons
ncons_opr_com:
	staq	bb|0		store arg into car of allocated cons
	ldaq	ab|nil
	staq	bb|2		store nil into cdr of allocated cons
	tra	cons_opr_com1

	segdef 	xcons_opr
xcons_opr:tsx6	opr_cons
	staq	bb|2
	tsx6	opr_ck_fault
	ldaq	bb|2		reload aq from cdr of cons
	tra	bp|0

	segdef	begin_list_opr	operator to get the first element of a list
begin_list_opr:
	tsx6	opr_cons
	eppap	ap|2		push result on stack for later list oprs.
	spribb	ap|-2
	tra	cons_opr_com0

	segdef	append_list_opr
append_list_opr:
	tsx6	opr_cons
	eax6	2		to save a register
	spribb	ap|-2,*x6		rplacd onto old list
	spribb	ap|-2		and store in old list place.
	tra	cons_opr_com0

	segdef	terminate_list_opr
terminate_list_opr:
	tsx6	opr_cons
	eax6	2
	spribb	ap|-2,*x6		rplacd onto end of list
	eppap	ap|-2		wipe temp off stack
	tra	ncons_opr_com	and set portions of new cons.


" Operator to cons up a string
" called by tspbp with length (in characters) in q
" returns pointer to string in both bb and aq.  stringlength is stored

	segdef	cons_string

cons_string:
	eax5	0,ql		save length
	adq	15+4,dl		allow for length word + 4-word blocks
	qrs	4		divide by 4 chars/wd + 4 wds/block
	qls	2		then allow for words_alloc strangeness
	eax7	2,x7		save caller's lp and address
	sprplp	ab|-2,x7
	sprpbp	ab|-1,x7
	epplp	ab|system_lp,*
	tsx6	words_alloc	get space for the string
	eppbb	bp|0		and move pointer into proper register
	lprplp	ab|-2,x7		restore regs
	lprpbp	ab|-1,x7
	stz	bb|0		set length word
	sxl5	bb|0		..
	spribb	ab|-2,x7		move bb into aq
	ldaq	ab|-2,x7
	ora	String,dl
	eax7	-2,x7
	tra	bp|0	
"
"  common routine to allocate a cons for the operators
"
"	uses lb to point to linkage section,
"	returns result in bb,
"	saves aq, bp, lp, x6.

opr_cons:	epplb	ab|system_lp,*	get our lp into lb register
	stc1	lb|alloc_fault_word	lock out interrupts
	eppbb	lb|consptr,*	allocate a cons
	ttf	0,x6		and if no tally runout, return

	aos	lb|gc_blk_cntr	check for gc.
	tmi	no_opr_gc
	tsx4	save_regs_call	save regs and execute next instruction.
	tra	must_gc
	tsx4	unsave_regs
no_opr_gc:aos	lb|seg_blk_cntr	check if out of segment room
	tmi	0,x6		if not, can return
	tsx4	save_regs_call
	tra	get_new_seg
	div	0,dl		get_new_seg returns to reallocate
				" never to here (hopefully)
save_regs_call:
	eppap	ap|2
	eax7	2,x7
	staq	ap|-2		save aq on marked stack
	sprplp	ab|-2,x7		save lp
	sprpbp	ab|-1,x7	and bp
	epplp	lb|0		get lb into lp.
	ldx5	lb|alloc_fault_word	kludge saving restart address in x5
	eax3	unsave_retry	and storing addr of unsaver in restart address
	stx3	lb|alloc_fault_word
	eax4	1,x4		get real return address
	xec	-1,x4		and execute instruction after call

unsave_retry:
	eax4	0,x5		restart at allocation point
unsave_regs:
	ldaq	ap|-2		reload aq
	epplb	lp|0		move lp into lb again
	lprplp	ab|-2,x7		reload caller's lp
	lprpbp	ab|-1,x7		and bp
	stx5	lb|alloc_fault_word	restore stc1 word to original state
	eppap	ap|-2		pop off stack
	eax7	-2,x7
	tra	0,x4		and return

"
" routine used by oprs to check for faults while allocating
"
"	clobbers a register.

opr_ck_fault:
	ldac	lb|alloc_fault_word	unit operation
	ana	=o7,dl		mask out fault bits
	tze	0,x6		if no fault, return

	eax5	0,x6		save x6 in x5
	eax7	4,x7
	spribb	ab|-4,x7		save registers not saved in other allocator fault checker
	sprilp	ab|-2,x7
	epplp	lb|0
	tsx6	alloc_got_fault
	epplb	lp|0		unsave stuff
	epplp	ab|-2,x7*
	eppbb	ab|-4,x7*
	eax7	-4,x7
	tra	0,x5		return to caller
"
	entry	lisp_alloc_		" pl1 callable allocation routine.
lisp_alloc_:
	eppbp	ap|0			" get pointer to arg list.
	tsx6	switch_to_lisp-*,ic		" load ab, ap, x7 etc.
	eax7	2,x7			" get some space for second arg pointer save.
	ldaq	bp|4			" load pointer to second arg.
	staq	ab|-2,x7			" and save it.
	ldq	bp|2,*			" load first arg, number of words needed.
	adq	3,dl			" round it to mod 4.
	anq	=o777774,dl		" and ignore high order bits too.
	tsx6	words_alloc-*,ic		" allocate number of words in q, return in bp.
	spribp	ab|-2,x7*			" save in second argument.
	eax7	-2,x7
ret_to_pl1:				" return to pl1 conventions.
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	short_return			" return to caller, no stack frame exists.
"
"	Entries called from pl1 programs in the lisp system.
"	called as lisp_special_fns_$xxxx.

	entry	cons
cons:	tsx6	switch_to_lisp-*,ic		" switch to lisp calling conventions.
	eax7	4,x7			" get room to do a lisp call to cons_
	sprilp	ab|-4,x7			" store lp
	stcd	ab|-2,x7			" store return address.
	tra	cons_-*,ic
pl1_ret:	eppap	ap|2			" get room to push result on stack.
	staq	ap|-2			" and push it.
	tra	ret_to_pl1-*,ic		" return and switch back to pl1 conventions.

	entry	xcons
xcons:	tsx6	switch_to_lisp-*,ic
	eax7	4,x7
	sprilp	ab|-4,x7			" call to xcons_ via lisp call.
	stcd	ab|-2,x7
	tra	xcons_-*,ic
	tra	pl1_ret-*,ic

	entry	ncons
ncons:	tsx6	switch_to_lisp-*,ic		" switch to lisp calling conventions.
	eax7	4,x7
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	ncons_-*,ic
	tra	pl1_ret-*,ic

	entry	list
list:	tsx6	switch_to_lisp-*,ic
	lxl5	ap|-1			" laod number of args * -2
	eppap	ap|-2			" pop off stack.
	eax7	4,x7
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	list_-*,ic
	tra	pl1_ret-*,ic

	entry	list_star
list_star:
	tsx6	switch_to_lisp
	lxl5	ap|-1			" laod number of args * -2
	eppap	ap|-2			" pop off stack.
	eax7	4,x7
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	list_star_
	tra	pl1_ret

	entry	gensym
gensym:	tsx6	switch_to_lisp-*,ic
	lxl5	ap|-1		get number args into x5
	eppap	ap|-2		pop off stack
	eax7	4,x7		get room to save lp and return link
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	gensym_-*,ic	and call lisp gensym function.
	tra	pl1_ret-*,ic	then return

	entry	subst
subst:	tsx6	switch_to_lisp
	eax7	4,x7
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	subst_
	tra	pl1_ret

	entry	nreverse
nreverse:	tsx6	switch_to_lisp
	eax7	4,x7
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	nreverse_
	tra	pl1_ret


	entry	get_fault_word
get_fault_word:			" subroutine to get a copy of alloc_fault_word, and zero it at the same time.
				" must be done in a way such that interrupts don't foul it up.
				" interrupts can or new things into the fault word...
	stz	ap|2,*		" zero result.
gfw_lp:	lda	lp|alloc_fault_word	" get fault word.
	orsa	ap|2,*		" or bits gotten into result.
	ersa	lp|alloc_fault_word	" and clear those bits in the fault word.
	tnz	gfw_lp-*,ic	" if more bits turned on since two insts. ago, get them.
	short_return

	entry	set_fault
set_fault:
	lda	ap|2,*
	orsa	lp|alloc_fault_word		" set fault on.
	short_return
"
	segdef	cons_
cons_:	tsx6	cons_alloc-*,ic		"allocate 4 words for cons
	ldaq	ap|-4			"load soon-to-be car
	staq	bp|0			"make it car.
	ldaq	ap|-2			"load soon-to-be cdr
xcret:	staq	bp|2
	spribp	ap|-2
	ldaq	ap|-2			"get result in aq
	eppap	ap|-4			"pop back  stack
retrn:	epplp	ab|-4,x7*			"reload caller's lp
	eppbp	ab|-2,x7*			"and bp
	eax7	-4,x7
	tra	bp|0			return

	segdef	xcons_
xcons_:	tsx6	cons_alloc-*,ic		"get 4 words
	ldaq	ap|-2			"load car
	staq	bp|0
	ldaq	ap|-4			"load cdr
	tra	xcret-*,ic		"and join with cons code.

	segdef	ncons_
ncons_:	tsx6	cons_alloc-*,ic		"get 4 words
	ldaq	ab|nil
	staq	bp|2
	ldaq	ap|-2
	staq	bp|0
	spribp	ap|-2
	ldaq	ap|-2
	eppap	ap|-2
	tra	retrn-*,ic

	segdef	list_star_
list_star_:
	eax5	2,x5			"we need one fewer cons than list_ does
					"Avoid ap push. Our 'cddddddr' tail is
					"already same place as list's running tail.
	tnz	list_lp			"so skip nil and make list
	tra	ret_list			"one arg, we are noop, pop and return arg

	segdef	list_
list_:	eppap	ap|2			"get room for tail of list
	ldaq	ab|nil			"load initial tail.
	staq	ap|-2
	cmpx5	0,du			"check x5 for no args.
	tze	ret_list-*,ic
list_lp:	tsx6	cons_alloc-*,ic
	ldaq	ap|-2			"load tail of list
	staq	bp|2			"and make it cdr
	ldaq	ap|-4
	staq	bp|0			"make next last thing car.
	spribp	ap|-4
	eppap	ap|-2			"pop off old tail.
	eax5	2,x5		"one less arg.
	tnz	list_lp-*,ic
ret_list:	ldaq	ap|-2			"load last result.
	eppap	ap|-2			"pop off stack
	tra	retrn-*,ic


" gensym function...coded in alm for speed.

	segdef	gensym_		" regular lisp subr entry point.
gensym_:	cmpx5	0,du		" check for any arguments
	tmi	set_gensym_data-*,ic " and jump to special routine if so.

gensym_begin:
	ldq	8,dl		" need 8 words for the atom.
	tsx6	words_alloc-*,ic
	lda	5,dl		" put 5 in name length field.
	sta	bp|4
	ldaq	ab|nil		" and nil in property list.
	staq	bp|2

	aos	ab|gensym_data+1	increment the counter
	lda	ab|gensym_data+1	check for wrap-around
	cmg	9999,dl
	tmoz	2,ic
	stz	ab|gensym_data+1	wraps around to 0 instead of 1.  OK?
	btd	(pr),(pr)		now convert to decimal and stick into pname
	desc9a	ab|gensym_data+1,4
	desc9ns	bp|5(1),4
	mlr	(pr),(pr)		don't forget the "g"
	desc9a	ab|gensym_data,1
	desc9a	bp|5,1
	epaq	bp|0		get atomic symbol as lisp object in aq
	eaa	0,au		clear out ring number
	ora	Atsym+35,dl	turn on type bit and 043 modifier
	tra	retrn-*,ic

set_gensym_data:
	ldaq	ap|-2
	cmpa	fixnum_type,dl		" check for new index
	tnz	chk_prefix-*,ic
	stq	ab|gensym_data+1		store new index in binary
	tra	set_gensym_loop-*,ic
chk_prefix:
	cana	Atsym,dl		" prefix set from atomic symbol
	tze	gensym_err-*,ic
	eppbp	ap|-2,*
	lda	bp|5		" get prefix,
	sta	ab|gensym_data	"and save it.

set_gensym_loop:
	eppap	ap|-2
	eax5	2,x5		" bump back pointers,
	tpl	gensym_begin-*,ic	" and start if done with arguments.
	tra	set_gensym_data-*,ic

gensym_err:
	eax7	4,x7		" get room for error data and save area.
	lda	bad_arg_correctable,dl
	lcq	-fn_gensym,dl
	staq	ab|-2,x7
	stx5	ab|-4,x7
	tsx6	save_for_pl1_call-*,ic
	eppap	noargs-*,ic
	short_call <lisp_error_>|[lisp_error_]
	tsx6	pop_back_to_lisp-*,ic
	ldx5	ab|-2,x7
	eax7	-2,x7
	tra	set_gensym_data-*,ic	" try again if error returns.

" copysymbol function. takes two args, first is atsym, second flag.
" makes new atom with same pname as first, if flag is nil, it is otherwise unsharing.
" if flag is t, will put copy of prop list on as its prop list, and copy the value.

	segdef	copysymbol
copysymbol:
	ldaq	ap|-4		"get arg.
	cana	Atsym,dl
	tnz	copysym
	eppap	ap|-4		" should be error? we just return arg.
	tra	retrn

copysym:	eppap	ap|2		" get working space.
	eppbp	ap|-6,*
	ldq	bp|4		" get length of pname
	adq	35,dl		" round to 4 word multiple
	qrs	4		" ..
	qls	2		" ..
	tsx6	words_alloc	" allocate new atom.
	spribp	ap|-2
	lda	Atsym,dl
	orsa	ap|-2

	eppbb	ap|-6,*		" get pointer to original atom.
	ldq	bb|4		" get length
	stq	bp|4		" and set length of new atom
	mlr	(pr,rl),(pr,rl)	" move in name.
	desc9a	bb|5,ql
	desc9a	bp|5,ql		" done move
	ldaq	ap|-4		" check falg.
	cmpaq	ab|nil
	tnz	copypropl
	staq	bp|2		nullify prop list
	tra	return_copy

copypropl:
	ldaq	bb|0		" get value
	staq	bp|0
	eppap	ap|4		" args for append
	ldaq	ap|-10		" see if symbol being copied is nil
	cmpaq	ab|nil
	tze	copypropl_nil-*,ic	" yes, get property list from different place.
	ldaq	bb|2		" get old prop list
copypropl_0:
	staq	ap|-4
	ldaq	ab|nil
	staq	ap|-2
	eax5	-4
	eax7	4,x7		" get room for push of return addr
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	append		" call append
	eppbb	ap|-2,*		" get poiner to new atom
	staq	bb|2		" and store new prop list

return_copy:
	ldaq	ap|-2
	eppap	ap|-6
	tra	retrn

copypropl_nil:
	ldaq	<lisp_static_vars_>|[property_list_of_nil]
	tra	copypropl_0-*,ic


"	append and nconc subroutines. both are lsubrs with any number of args.

	segdef	append

append:	cmpx5	0,du		" check for no args
	tze	ret_nil-*,ic	" return nil in this case.
	eppap	ap|4		" get room for result, and scanning pointer.
	eax7	2,x7		" also, save stack popping point,
	stx5	ab|-2,x7		" so x5 can be changed....

skip_atoms:			" first skip leading atomic arguments.
	ldaq	ap|-4,x5		" load next arg,
	eax5	2,x5		" and move up stack,
	tze	ret_arg-*,ic	" but if last arg, just return.
	cana	Atomic,dl		" check for atom
	tnz	skip_atoms-*,ic	" and skip if so.

	tsx6	cons_alloc-*,ic	" allocate initial cons, and make it the result.
	ldaq	ap|-6,x5*		" copy car of current list in...
	staq	bp|0		" ....
	spribp	ap|-4		" make this the result.
aplp:	spribp	ap|-2		" make allocated cons the scan pointer.
	eppbp	ap|-6,x5*		" move to next list cell of argument.
	ldaq	bp|2		" ...
	staq	ap|-6,x5		" ...
chk_list:	cana	Atomic,dl		" check to see if we are still following a list.
	tnz	end_list-*,ic
	tsx6	cons_alloc-*,ic	" allocate another cell.
	ldaq	ap|-6,x5*		" copy car of this list cell in.
	staq	bp|0		" ...
	eax2	2		" set cdr of scan pointer to new cell
	spribp	ap|-2,*x2		" ...
	tra	aplp-*,ic		" and continue, updating scan pointer.

end_list:	ldaq	ap|-4,x5		" load next argument.
	eax5	2,x5		" and move up arg list.
	tmi	chk_list-*,ic	" if not last arg, continue.
	eppbp	ap|-2,*		" otherwise, make last arg cdr of final list.
	staq	bp|2		" ...
	ldaq	ap|-4		" load result.
ret_arg:	ldx5	ab|-2,x7		" reload x5.
	eax7	-2,x7		" pop stack.
	eppap	ap|-4,x5		" ...
	tra	retrn-*,ic

	segdef	nconc

nconc:	eax4	0,x5		" save height of stack to restore to.
	tze	ret_nil-*,ic	" if no args, nil is the result.
	eax5	2,x5
	tze	retn-*,ic		" if one arg, just return it.

	eppbp	ap|-4,x5		" bp points so that bp|2 is replaced
				" by next arg, always.
nclp:	lxl0	bp|2		" load type field of cdr.
	canx0	Atomic,du		" check for atom.
	tnz	zap-*,ic

	eppbp	bp|2,*		" go to cdr otherwise.
	tra	nclp-*,ic		" and continue looking for end.

zap:	ldaq	ap|0,x5		" load next arg.
	staq	bp|2		" zap it in cdr of list.
	eax5	2,x5		" bump number of args.
	tnz	nclp-*,ic		" if more, continue down new list.
retn:	ldaq	ap|0,x4		" load first arg,
	eppap	ap|0,x4		" and return it.
	tra	retrn-*,ic

ret_nil:	ldaq	ab|nil		" load nil
	tra	retrn-*,ic	" and return it.

"	lisp reverse and nreverse functions...
"	they reverse a list argument by copying in the first instance,
"	or by rplacd's in the second instance.
"	both are type 1 subrs.
"
	segdef	reverse
reverse:	ldaq	ap|-2		load argument.
	cana 	Atomic,dl		and check for atom
	tze	not_atom_reverse
	eppap	ap|-2
	tra	retrn		return directly if not list.
not_atom_reverse:
	eppap	ap|2		get storage to play with.
	ldaq	ab|nil		init result to nil.
	staq	ap|-2
rev_loop:	tsx6	cons_alloc	get a cons cell
	ldaq	ap|-2		and move previous result into its cdr.
	staq	bp|2		..
	spribp	ap|-2		make this cons the new result.
	eppbp	ap|-4,*		load the car of the remainder of the argument
	ldaq	bp|0
	staq	ap|-2,*		and move it into the car of the new result.
	ldaq	bp|2		now load the cdr of the argument
	staq	ap|-4		and make it the new argument.
	cana	Atomic,dl	check to see if more to reverse.
	tze	rev_loop		if more, continue....
	ldaq	ap|-2		load up the result
	eppap	ap|-4
	tra	retrn		and return.


	segdef	nreverse_		nreverse subr...pl1-callable version also in this module.
nreverse_:eppap	ap|2		get a temporary
	ldaq	ab|nil
	staq	ap|-2
	ldaq	ap|-4		unshare nreconc at this point 6/11/80
	cana	Atomic,dl		atoms lose here
	tnz	nrev_ret
nrev_loop:eppbp	ap|-4,*		get pointer to cons...
	ldaq	bp|2
	staq	ap|-4		move its cdr to the result location.
	ldaq	ap|-2		load previous result pointer.
	staq	bp|2		and make it the cdr of the result.
	spribp	ap|-2		now the back pointer points at the current cell.
	ldaq	ap|-4		load the next result.
	cana	Atomic,dl		check for atom, which would lose....
	tze	nrev_loop
	ldaq	ap|-2		load up the back pointer.
nrev_ret: eppap	ap|-4
	tra	retrn		return result.

	segdef	nreconc_		nreconc subr...nreverse followed by nconc...joins here
nreconc_:
	ldaq	ap|-4
	cana	Atomic,dl		check for atom which terminates list.
	tze	nrev_loop		fixed nreconc 6/11/80 BSG
	ldaq	ap|-2
	tra	nrev_ret

"	lisp subst subroutine...copies a list, making substitutions.

	segdef	subst_		there is also a pl1-callable entry point.
subst_:	eax5	-6		note the stack depth at entry time.
	ldaq	ap|-2
	tsx6	subst_loop	call the right subroutine to do the job.
	eppap	ap|-6		pop stack
	tra	retrn		and return.

subst_loop:
	cmpaq	ap|2,x5		compare current lisp value with second arg.
	tze	ret_1st_arg	if same, replace with first arg.
	cana	Atomic,dl		check to see if a leaf of the tree.
	tnz	0,x6		and return if so.

	eax5	-2,x5		add to the depth of the args.
	eppap	ap|2		get room for recursion
	eax7	2,x7		on both stacks.
	staq	ap|-2		save argument.
	stx6	ab|-2,x7		save return address
	ldaq	ap|-2,*		load car of argument.
	tsx6	subst_loop	call subst recursively.
	eppbp	ap|-2,*
	staq	ap|-2		store result of subst on car,
	ldaq	bp|2		and load the cdr.
	tsx6	subst_loop	call subst again.
	eppap	ap|2		get room to save aq
	staq	ap|-2
	tsx6	cons_alloc	call the allocator.
	ldaq	ap|-4		now fill in cons pointed at by bp.
	staq	bp|0
	ldaq	ap|-2
	staq	bp|2
	spribp	ap|-2		move bp to aq
	ldaq	ap|-2
	eppap	ap|-4		and pop stack.
	eax5	2,x5
	ldx6	ab|-2,x7		reload return address.
	eax7	-2,x7		pop unmarked stack
	tra	0,x6		and return.

ret_1st_arg:
	ldaq	ap|0,x5		load 1st arg to top call.
	tra	0,x6		and return it.



""" sublis hacked to use rpt instruction
""" 74.04.27 by DAM

" Register conventions
"
" aq	passing arguments in and out of sublis1
" x7	unmkd pdl ptr as usual
" x6	subroutine calling.  note sublis1 skip returns if it was unchanged.
" x5	value to go in x0 for rpt to scan table.
" x4	number of 256 - item table portions
" x3	temp.
" x2	always contains 2, for cdr'ing
" x1	temp
" x0	temp
" bp	cons ptr
" lb	temp
" bb	-> array of atoms and substitute expressions in stack
"
" stack conventions
"
" ab|-2,x7	register save area for sublis_cons
" ab|-1,x7	LH - save x6 for recursive calls.
" 		RH - register save area for sublis_cons

	segdef	sublis

	bool rpt_tze,100

sublis:	"" first step - construct a table from the first argument.

	eppbb	ap|0		-> table
	eax5	0		number of entries in table
	eax2	2
	ldaq	bb|-4		get list of dotted pairs
sublis0:	cana	lisp_ptr.type,dl
	tnz	got_sublis_table
	epplb	bb|-4,*		get cons of list
	ldaq	lb|0,*		get atomic symbol
	eppap	ap|4		append to table
	eax5	1,x5		increase count
	staq	ap|-4
	ldaq	lb|0,*2		get expression to substitute for symbol
	staq	ap|-2
	ldaq	lb|2		cdr the first argument
	staq	bb|-4
	tra	sublis0

got_sublis_table:
	eaa	0
	eaq	0,x5		set up registers for rpt later
	lls	10
	qls	0
	tnz	2,ic
	 sba	 1,dl		0=256.
	eax5	rpt_tze,qu	value to go in x0 (first rpt count)
	eax4	1,al		value to go in x1 (number of repetitions)
	tmoz	no_sublis		nothing to do.

	"" second stage - begin scanning argument.

	ldaq	bb|-2		second argument
	tsx6	sublis1
	nop	0		in case it skip returns.

	eppap	bb|-4		pop stack and return the result
	tra	retrn


no_sublis:
	ldaq	bb|-2
	eppap	bb|-4
	tra	retrn

sublis1:	"" sublis the form in aq - return addr is at ab|-2,x7

	cana	lisp_ptr.type,dl		atom?
	tze	sublis2			no, cdr down it.
" this is an atom, so look it up in the table.
" HERE IS THE GROSSNESS:

	eax1	0,x4
	eax3	0
	eax0	0,x5
sublis_rpt:
	rptx	,4
	cmpaq	bb|0,x3
	ttf	sublis_substitute_here
	eax0	rpt_tze			repetitions after first are 256. at a time
	eax1	-1,x1
	tnz	sublis_rpt
	tra	1,x6		not found, leave it the same.

sublis_substitute_here:
	ldaq	bb|-2,x3		x3 4 too high.  Pick up thing to be substituted.
	tra	0,x6		return non-skipping to indicate change.

sublis2:	"" sublis of a cons.  do car and cdr

	eax7	2,x7
	eppap	ap|2
	staq	ap|-2
	stx6	ab|-1,x7			save previous return address
	ldaq	ap|-2,*			car
	tsx6	sublis1
	tra	sublis_car_changed		changed, have to make a new cons.
	ldaq	ap|-2,*2			no, get cdr
	tsx6	sublis1
	tra	sublis_cdr_changed		changed, have to make a new cons.
	ldaq	ap|-2			no change, return same old cons.
	eppap	ap|-2
	ldx6	ab|-1,x7
	eax7	-2,x7
	tra	1,x6

sublis_cdr_changed:
	tsx6	sublis_cons
	staq	bp|2			store new cdr
	ldaq	ap|-2,*
	staq	bp|0			store new car
	spribp	ap|-2			store back new cons
sublis_change_exit:
	ldaq	ap|-2
	eppap	ap|-2
	ldx6	ab|-1,x7
	eax7	-2,x7
	tra	0,x6			it changed

sublis_car_changed:
	tsx6	sublis_cons		make new cons
	staq	bp|0			save car
	ldaq	ap|-2,*2			get old cdr
	spribp	ap|-2			store back new cons
	tsx6	sublis1			sublis the cdr
	nop	0			doesn't matter whether it changed
	staq	ap|-2,*2			store cdr
	tra	sublis_change_exit


sublis_cons:	" special cons routine for sublis, avoids munging aq, bb, x5,x4,
		" returns cons ptr in bp.
		" called by tsx6

	eppap	ap|2			got to save aq across ldac, gc
	staq	ap|-2			save regs
	sarbb	ab|-2,x7			KLUDGE
	sxl4	ab|-2,x7
	sxl6	ab|-1,x7
	tsx6	cons_alloc
	lxl6	ab|-1,x7
	lxl4	ab|-2,x7
	ldaq	ap|-2
	eppap	ap|-2			now how am I going to get out of this one?
	epbpbb	ap|0			KLUDGE
	adwpbb	ab|-2,x7			..	(note - due to hardware bug must be even address)
	eax2	2			x2 has to always have 2 in it.
	tra	0,x6

"	functions to deal with value cells.
"	boundp returns t if bound, nil if not (changed 9/12/74)
"	makunbound makes an atom unbound at this binding level -- usually top level.
"
	segdef	boundp
boundp:	eax4	0,ic		" remember retry address.
	ldaq	ap|-2		" load argument.
	cana	Atsym,dl
	tze	not_atsym-*,ic	" signal error.
	ldaq	ap|-2,*		" load value cell.
	tze	not_bound-*,ic	" return nil if not bound.
	ldaq	ab|true
	eppap	ap|-2		" pop off argument
	tra	retrn-*,ic	" else return t

not_bound: eppap	ap|-2	" pop off argument.
	tra	ret_nil-*,ic

	segdef	makunbound
makunbound: eax4	0,ic		" remember retry address.
	ldaq	ap|-2
	cana	Atsym,dl
	tze	not_atsym-*,ic
	fld	0,du		" zero is the unbound marker.
	staq	ap|-2,*
	ldaq	ap|-2
	eppap	ap|-2
	tra	retrn-*,ic
not_atsym:lda	bad_arg_correctable,dl
	cmpx4	boundp,du		" determine which function got error.
	tze	3,ic
	lcq	-fn_makunbound,dl	" and load correct error code
	tra	2,ic		" ..
	lcq	-fn_boundp,dl	" ..
	eax7	4,x7
	stx4	ab|-4,x7		"save return address.
	staq	ab|-2,x7
	tsx6	save_for_pl1_call-*,ic
	eppap	noargs-*,ic
	short_call <lisp_error_>|[lisp_error_]
	tsx6	pop_back_to_lisp-*,ic
	ldx4	ab|-2,x7		" get back retry address.
	eax7	-2,x7
	tra	0,x4		" and retry.
"
" maknum function, returns unique number.
	segdef	maknum

	equ	prime,338417659 " or maybe 2796203
	equ	maknum_initial,32
maknum:	eax7	2,x7
	stc1	lp|alloc_fault_word
	szn	<lisp_static_vars_>|[maknum_mask]
	tpl	maknum1
	ldq	maknum_initial*2,dl
	tsx6	locked_alloc
	spribp	<lisp_static_vars_>|[maknum_table_ptr]
	lcq	maknum_initial/2,dl
	stq	<lisp_static_vars_>|[maknum_left]
	stz	<lisp_static_vars_>|[maknum_next]
	ldq	maknum_initial*8-1,dl
	stq	<lisp_static_vars_>|[maknum_mask]
maknum1:	ldaq	ap|-2
	cana	Fixed+Float,dl
	tnz	maknumber
	alr	18		" move seg number to Q...
	lrs	18
maknumber:
	ars	6		" type field to low char of A
	staq	ab|-2,x7
	mpy	=v36/prime
	qrs	18
	qls	3
	eppbp	<lisp_static_vars_>|[maknum_table_ptr],*
	epplb	ab|-2,x7
loopmake: anq	<lisp_static_vars_>|[maknum_mask]
	cmpc	(pr,ql),(pr)
	desc9a	bp|0(3),5
	desc9a	lb|0(3),5
	tze	found_maknum

	cmpc	(pr,ql)
	desc9a	bp|0,4
	desc9a	0,0
	tze	maknewnum
	adq	8,dl
	tra	loopmake

found_maknum:
	qrs	2
	ldq	bp|0,ql
	lda	fixnum_type,dl
	staq	ab|-2,x7
	ldac	lp|alloc_fault_word
	ana	=o7,dl
	tze	nomakfault
	tsx6	alloc_got_fault

nomakfault:
	ldaq	ab|-2,x7
	eax7	-2,x7
	eppap	ap|-2
	tra	retrn


maknewnum:
	aos	<lisp_static_vars_>|[maknum_left]
	tpl	rehash
	eppbb	<lisp_static_vars_>|[maknum_next]
	aos	bb|0
	mlr	(pr),(pr,ql)
	desc9a	bb|0(1),3
	desc9a	bp|0,3
	mlr	(pr),(pr,ql)
	desc9a	lb|0(3),5
	desc9a	bp|0(3),5
	tra	found_maknum



rehash:
	ldq	<lisp_static_vars_>|[maknum_mask]
	qls	1	"double table size
	orq	1,dl
	stq	<lisp_static_vars_>|[maknum_mask]
	adq	1,dl
	qls	18-3
	stq	ab|-2,x7
	qrs	18-1
	tsx6	locked_alloc	"alloc while already locked.
	tsx6	maknum_rehash
	szn	lp|gc_blk_cntr
	tmi	maknum1

	" if overflowed gc limit, go to must_gc.

	eax0	maknum1
	stx0	lp|alloc_fault_word
	tsx4	must_gc
	tra	maknum1

" subroutine to rehash a maknum table into another.
" args: bp -> new table space.
"       <lisp_static_vars_>|[maknum_table_ptr] -> old table space.
"       ab|-2,x7 (DU) has size of old table in words.
"       <lisp_static_vars_>|[maknum_mask] has new table size in chars (-1)
" sets: maknum_table_ptr to point to new table.
"       maknum_left to trigger next rehash.

maknum_rehash:
	eppbb	<lisp_static_vars_>|[maknum_table_ptr],*
	spribp	<lisp_static_vars_>|[maknum_table_ptr]

	stz	ab|-1,x7	"count moves.
	eax0	0
rhsh_loop:cmpx0	ab|-2,x7
	tze	done_rhsh
	ldq	bb|0,x0	"check for stuff
	tze	skip_rhsh
	ldq	bb|1,x0
	mpy	=v36/prime
	qrs	18
	qls	3
rhshlp1:	anq	<lisp_static_vars_>|[maknum_mask]
	cmpc	(pr,ql)	"check for enpty slot
	desc9a	bp|0,4
	desc9a	0,0
	tze	insrt
	adq	8,dl
	tra	rhshlp1
insrt:	qrs	2
	eax1	0,ql
	ldaq	bb|0,x0
	staq	bp|0,x1
	aos	ab|-1,x7
skip_rhsh:eax0	2,x0
	tra	rhsh_loop
done_rhsh:
	lda	<lisp_static_vars_>|[maknum_mask]
	ada	1,dl
	ars	3
	sba	ab|-1,x7
	neg	0
	ars	1
	sta	<lisp_static_vars_>|[maknum_left]
	tra	0,x6

" pl1-callable subroutine to rehash maknum table. called by
" garbage collector and saver.  doesn't expect table to be hashed.
" args: <lsv>|[maknum_table_ptr] -> source table.
"       <lsv>|[maknum_mask] is old size in chars -1.
"       <lsv>|[maknum_left] is number of entries used in old table.
" sets: the above, so that maknum will work.

	entry	rehash_maknum
rehash_maknum:
	tsx6	switch_to_lisp
	eax7	2,x7
	ldq	<lisp_static_vars_>|[maknum_mask]
	adq	1,dl
	qls	18-2	" move to upper half, dividing by 4.
	stq	ab|-2,x7	" and put where rehash_maknum expects it.
	ldq	<lisp_static_vars_>|[maknum_left] " compute necessary ht size.
	qrs	4		" need next largest power of 2 > 32 and > number entries.
	eax0	4
nlgp2:	eax0	1,x0
	qrs	1
	tnz	nlgp2
	ldq	1,dl
	qls	4,x0	" (chars/word)*4*old_min_table_size
	sbq	1,dl
	stq	<lisp_static_vars_>|[maknum_mask]
	adq	1,dl
	qrs	2
	tsx6	words_alloc
	tsx6	maknum_rehash
	eax7	-2,x7
	tra	ret_to_pl1

	segdef	munkam
munkam:
	lda	ap|-2		" get  type.
	cmpa	fixnum_type,dl
	tnz	munfound
	lda	ap|-1
	ldq	<lisp_static_vars_>|[maknum_mask]
	tmi	munfound
	qrs	2
	eppbp	<lisp_static_vars_>|[maknum_table_ptr],*
mnkamlp:	cmpa	bp|-1,ql
	tze	mfound
	sbq	2,dl
	tpl	mnkamlp
munfound:
	ldaq	ab|nil
	tra	retrnmun	"should  probably err out here.



mfound:	als	6
	ana	lisp_ptr.type,dl
	cana	Fixed+Float,dl
	tnz	munnum
	eax7	2,x7
	lprpbp	bp|0,ql
	spribp	ab|-2,x7
	ora	ab|-2,x7
	ldq	ab|-1,x7
	eax7	-2,x7
	tra	retrnmun
munnum:	ora	=o47,dl
	ldq	bp|0,ql
retrnmun:
	eppap	ap|-2
	tra	retrn
"
	include	lisp_object_types
	include	lisp_stack_seg
	include 	lisp_error_codes
	include 	lisp_name_codes
	include	stack_header
	include 	stack_frame
	end




		    lisp_bignums_.alm               11/05/86  1612.7r w 11/04/86  1039.1      638136



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
" lisp_bignums_
"
" N.B. The algorithms presented herein are either from
" Knuth's Art of Computer Programming, vol 2 (notation
" is saved once in a while), or are obvious (hopefully)
" and commented.
" Large sections of uncommented code (such as in div_bb) will
" be easier to read with Knuth's book beside you.
"
" The format of this set of routines is internal subroutines
" first, in alphabetic order, followed by code that is referenced
" from outside.
"
" Initially coded late 1972 and early 1973 by Dan Bricklin
" Modified 75.04.17 by DAM to fix bug in haipart and convert for 6180 a little
" Last modified Christmas Eve, 1980 by Richard Lamson to fix interaction
"	between call_alloc_bfx and garbage collector.
"
	segdef	convert_bfx_to_sfl
	segdef	plus
	segdef	difference
	segdef 	times
	segdef	quotient
	segdef	fix
	segdef 	float
	segdef	add1
	segdef	sub1
	segdef	minus
	segdef	abs
	segdef	minusp
	segdef	plusp
	segdef	max
	segdef	min
	segdef	lessp
	segdef	greaterp
	segdef	remainder
	segdef	expt
	segdef	haulong
	segdef	haipart
	segdef	gcd
"
	include stack_header
	include	lisp_object_types
	include	lisp_stack_seg
	include 	lisp_name_codes
"
	bool 	nooverflow,004000		"inhibits overflow and sets carry to zero
"
" these values are used to access the AUTOMATIC VARIABLES
"
	equ	old_lp,-4			"old lp - saved by caller
	equ	bn_pl1_ptr,-4		"ptr to array
	equ	return_point,-2		"return point, saved by caller
	equ	bn_pl1_length,-2		"size of array
	equ	bn_pl1_radix,-1		"arg from pl1 caller
	equ	num_of_args,0		"what x5 contained on entry, in upper 18 bits
	equ	saved_indicators,1		"what the indicator register was, saved with an sti
	equ	initial_value,2		"used by expt and gcd to keep umkdpdl at minimum
	equ	resultp,4			"ptr to result
	equ	biggerp,6			"ptr to bigger of the two
	equ	smallerp,8		"ptr to smaller of the two
	equ	divisor,8			"place to hold sfx divisor  
	equ	multiplier,8		"place to hold sfx multiplier
	equ	addend,8			"place to hold sfx addend
	equ	big_limit,10		"length of bigger of the two
	equ	small_limit,11		"length of smaller
	equ	temp,12			"temporary double word
	equ	op_table,14		"needed to decide if add or subtract is needed
	equ	carry,15			"holds carry in multiply
	equ	carrya,16			"another carry
	equ	shift_value,17		"number of bits to shift
	equ	shiftp,18			"where to put shifted result
	equ	divisorp,20		"ptr to divisor
	equ	dividendp,22		"ptr to dividend in bfx divide
	equ	answerp,24		"ptr to quotient in bfx divide
	equ	v1p,26
	equ	presultp,26
	equ	v2p,28
	equ	powerp,28
	equ	n,30
	equ	m,31
	equ	j,32
	equ	qhat,33
	equ	rhat,34
	equ	div_bb_ret,35
	equ	div_bb_temp,36
	equ	div_bb_lsh_ret,38
	equ	switched,39
	equ	function_name,40		"function name code for error
	equ	q,41
	equ	up,42
	equ	vp,44
	equ	ptemp1,46
	equ	ptemp2,48
	equ	ptemp3,50
	equ	ptemp4,52
	equ	uh,54
	equ	vh,55
	equ	A,56
	equ	B,57
	equ	C,58
	equ	D,59
	equ	auto_block_size,60		"size, in words, of the automatic block
"
"
"
"
abs_sfx_a_to_q:				"this routine puts the abs of the a into the q.
					"if still an sfx, then it skips one on return.
					"if too big, then it doesn't skip, and returns ptr to
					"bfx version in lp.
"
	lrs	36			"get into aq
	tpl	1,x0			"positive is ok - so skip
	negl	0			"do the abs
	cmpaq	=v36/0,o36/400000000000	"is it too big?
	tnz	1,x0			"no, so skip
	tra	convert_aq_to_bfx		"yes, so convert, and conversion routine will tra 0,x0
"
"
add_bb:					"this routine adds bigger and smaller, and
					"puts result in result (already alloced).  It takes
					"care of sign problems.
"
	stx0	bp|n			"save return point
	eax4	add_opcode		"remember that we want to add
	stx4	bp|op_table
	stz	bp|switched
	lxl2	bp|biggerp,*		"set up limits
	stx2	bp|big_limit
	lxl2	bp|smallerp,*
	stx2	bp|small_limit
	tsx0	compare_bfx		"bigger better be bigger
	tsx0	switch_bfx
	nop	0,dl
	nop	0,dl
	ldx2	bp|biggerp,*		"if signs are different, subtract
	erx2	bp|smallerp,*
	adx2	bp|op_table
	epplp	1,x2*			"exop wants info in lp
	ldx2	bp|biggerp,*		"set result sign
	xec	3,x4
	stx2	bp|resultp,*
	ldx0	bp|n			"restore return point
	tra	exop_bfx			"do the add
"
"
add_bs:					"this routine adds addend to bignum bigger.
"
	lxl2	bp|biggerp,*		"set big_limit
	stx2	bp|big_limit
	eax2	1			"get ptr to first word
	epplp	add_structure		"get ready to go to exop later
	ldq	bp|biggerp,*x2		"load first word of bignum
	adlq	bp|addend			"add the sfx
	lda	0,du			"clear the a
	lls	1			"get the carry there
	qrl	1
	stq	bp|resultp,*x2		"store the result
	tra	exop_bfx_ripple		"ripple the carry
"
"
alloc_bfx6:				"this routine allocs a bignum of length x6 on
					"the unmarked stack, and returns a ptr in lp
"
	epplp	ab|0,x7			"get the ptr
	eax6	2,x6			"add 1 for header word, and 1 for 2 rounding
	anx6	-2,du			"make even
	stx6	bp|temp			"add to x7
	adx7	bp|temp
	stz	lp|0			"certain routines assume sign is set "+"
	tra	0,x0			"return
"
"
bad_error:				"recoverable, but only by giving value for function
	eax7	8,x7			"get some space
	spribp	ab|-6,x7			"save bp
	ldq	bp|function_name		"get who we are, along with error (in aq)
	staq	ab|-2,x7			"give to lisp_error_
	tsx6	call_lisp_error_		"call the error printer
	eppbp	ab|-4,x7*			"get bp back
	ldaq	ap|-2			"get value to return to caller
	eppap	ap|-2			"pop it off the mkd stack
	eax7	-6,x7			"get rid of our temp storage
	tra	return			"return to caller
"
"
badarg:					"recoverable error - input wrong type
	eax7	8,x7			"get some space on unmkd pdl
	staq	ab|-8,x7			"save the aq
	spribp	ab|-6,x7			"save the bp (ptr to auto vars)
	lda	<lisp_error_table_>|[bad_arg_correctable]
	ldq	bp|function_name		"also the name of the function causing err
	staq	ab|-2,x7
	epplp	ap|0,x5			"get ptr to offending arg
	sprilp	ab|-4,x7			"remember where it was, for reseting
	ldaq	lp|0			"give it to lisp_error_
	eppap	ap|2			"bump marked pdl
	staq	ap|-2			"store it
	tsx6	call_lisp_error_		"call lisp_error_
	ldaq	ap|-2			"get corrected arg
	eppap	ap|-2			"pop mrkd pdl
	staq	ab|-2,x7*			"store over old, bad arg
	ldaq	ab|-6,x7			"restore aq
	eppbp	ab|-4,x7*			"restore bp
	eax7	-6,x7			"free this temp space (lisp_error_ frees 2)
	tra	numval			"go back and test type again
"
"
call_alloc_bfx:				"this routine replaces result with same bignum,
					"but allocated in lisp space.
"
	stx0	bp|temp			"save return point
	sxl3	bp|temp			"save x3
"
"	Now, we need to check to see if the bignum is in the heap.
"	If it is, the pointer to it has to be in the heap during the
"	call to lisp_alloc_, because otherwise the GC could smash it.
"
	stz	bp|temp+1			"set flag
	epaq	bp|0			"get segno of unmarked pdl
	eax3	0,au			"into x3
	cmpx3	bp|resultp		"is resultp in unmkd pdl?
	tze	do_call_alloc_bfx		"yes -- go do it
	stc1	bp|temp+1			"we need to copy resultp
	ldaq	bp|resultp
	ora	Big_fixed,dl		"make it a bignum for gc
	staq	ap|0			"put onto marked stack
	eppap	ap|2
do_call_alloc_bfx:
	epplp	ab|system_lp,*		"get ptr to linkage for call
	eax5	0,x1			"alloc routine preserves x5, and we
					"need x1 saved to get our auto vars back
	ldq	bp|resultp,*		"get number of words needed, on 4 boundary
	adq	4,dl
	anq	=o777774,dl
	tsx6	<lisp_alloc_>|[words_alloc]	"make the call to the alloc routine
	eax1	0,x5			"reload x1
	epplp	bp|0			"save ptr to alloced area in lp
	eppbp	ab|0,x1			"reload ptr to auto area
	szn	bp|temp+1			"did we copy pointer?
	tze	finish_call_alloc_bfx	"no -- done
	ldaq	ap|-2			"yes -- get it from stack
	eppap	ap|-2			"reset stack ptr
	staq	bp|resultp		"and put it back where it's expected
finish_call_alloc_bfx:
	tsx6	move_bfx			"move the result into new place
	sprilp	bp|resultp		"put ptr to result in resultp
	lxl3	bp|temp
	ldx0	bp|temp			"reload return point
	tra	0,x0			"return
"
"
call_lisp_error_:				"this routine calls lisp_error_
					"it is called by a tsx6
"
	epplp	ab|system_lp,*		"get ptr to linkage
	spriap	<lisp_static_vars_>|[stack_ptr]" save interesting ptrs
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code		"say we are in pl1
	push				"get place to save all registers
	call	<lisp_error_>|[lisp_error_]
	eaa	sp|16,*
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	tra	0,x6			"return to caller
"
"
check_aq:					"this routine skips if aq is an sfx.
"
	cmpaq	=v36/0,o36/400000000000
	tpl	0,x0			"no
	cmpaq	=v36/-1,o36/400000000000
	tpl	1,x0			"yes
	tra	0,x0			"no
"
"
compare_bfx:				"this routine compares bigger and smaller.
					"it skips 0, 1, or 2 for <, =, >.
					"it ignores the signs, and uses the limits for sizes
"
	ldx2	bp|big_limit		"load size of bigger
	cmpx2	bp|small_limit		"compare with smaller
	tmi	0,x0			"if smaller bigger, then b<s
	tze	2,ic			"if the same, then need more checking
	tra	2,x0			"otherwise, b>s, so skip 2
	eax2	1,x2			"add one to size, then start checking
compare_bfx_loop:
	eax2	-1,x2			"look at next lower order word
	tze	1,x0			"done - all equal => a=b so skip 1
	ldq	bp|biggerp,*x2		"load bigger number
	cmpq	bp|smallerp,*x2		"compare with smaller one
	tmi	0,x0			"smaller is bigger, so return no skip (b<s)
	tze	compare_bfx_loop		"try next word if equal
	tra	2,x0			"otherwise b>s, so skip 2
"
"
compare_signed_bfx:				"this routine compares bigger and smaller
					"taking into account the signs.
"
	ldx2	bp|biggerp,*		"compare signs
	cmpx2	bp|smallerp,*
	tmi	0,x0			"return with <
	tze	2,ic			"since we don't have a tpnz on 645
	tpl	2,x0			"return with >
	lxl3	bp|biggerp,*		"set up lengths
	stx3	bp|big_limit
	lxl3	bp|smallerp,*
	stx3	bp|small_limit
	eax2	0,x2			"check sign
	tmi	2,ic
	tra	compare_bfx		"for + it's the normal compare and return
	eax3	0,x0			"save return point
	tsx0	compare_bfx		"do a compare, and translate results for neg
	tra	2,x3			" >
	tra	1,x3			" =
	tra	0,x3			" <
"
"
convert_aq_to_bfx:				"this routine converts the aq to a bfx.
					"returns ptr to it in lp, and gives a bfx
					"of three words.  Won't work with -4000...
					"since it has to negate the aq
"
	epplp	ab|0,x7			"get ptr to bfx to be allocated
	eax7	4,x7			"alloc the bfx
	cmpaq	=0			"check sign
	tpl	4,ic			"skip around negate if plus
	negl	0			"do the negate
	eax2	-1			"load sign of result
	tra	2,ic
	eax2	0			"positive sign
	stx2	lp|0			"store the sign
	lls	1			"store each of the words
	qrl	1
	stq	lp|1
	eax2 	2			"load the tentative length
	lrl	35
	cmpa	0,dl
	tze	3,ic			"is the a zero? if so - length = 2
	sta	lp|3			"store the a if something there
	eax2	3			"length is 3
	qrl	1			"shift q to proper place
	stq	lp|2			"store the q
	sxl2	lp|0			"store the length
	tra	0,x0			"return
"
"
convert_bfx_to_sfl:				"this routine converts the bfx->by lp to an
					"sfl in the EAQ.  It is called by tsx6,
					"and only modifies x2.  It is an external entry.
					"It skips on return if conversion is ok, and
					"does not skip if there was an overflow
"
	lxl2	lp|0			"get length
	cmpx2	4,du
	tze	convert_bfx_to_sfl_check4	"4 is a special case - not all fit
	tpl	0,x6			"return if too big - no skip=>overflow
	lda	lp|0,x2			"load last (most sig.) word
	ldq	lp|-1,x2			"and next to last
	qls	1			"make one bit string (remove empty bit)
convert_bfx_to_sfl_l:
	lde	convert_bfx_to_sfl_tab,x2	"load an exponent
	fad	=0.0			"normalize
	ldx2	lp|0			"load the sign
	xec	convert_bfx_to_sfl_tab+1,x2	"perhaps negate
	tra	1,x6			"return with skip
convert_bfx_to_sfl_check4:
	lda	lp|0,x2			"load high order word
	cana	=vo14/37777,o22/0		"check if too big
	tnz	0,x6			"too big - don't skip
	ldq	lp|-1,x2			"load next word
	qls	1
	lls	14			"make so exponent isn't too big
	tra	convert_bfx_to_sfl_l	"join other code
convert_bfx_to_sfl_tab:
	fneg	0
	nop	0,dl
	vfd	8/70
	vfd	8/105
	vfd	8/127
"
"
convert_bfx_to_sfx:				"this routine converts result to an sfx -
					"if does not check to see if possible
"
	lxl2	bp|resultp,*		"load length
	cmpx2	2,du			"if length 2 then must be -400000000000
	tze	convert_bfx_to_sfx_2	"separate code for that
	lda	0,du			"clear a
	ldx2	1,du			"get address of low order word
	ldq	bp|resultp,*x2		"put it in q
	szn	bp|resultp,*		"do we need to negate it?
	tpl	2,ic			"no, skip neg instruction
	negl	0			"negate the aq
	lda	fixnum_type,dl		"add type bits
	tra	0,x0			"return
convert_bfx_to_sfx_2:
	ldq	=o400000000000		"load the value
	lda	fixnum_type,dl		"add type bits
	tra	0,x0			"return
"
"
convert_q_to_bfx:				"this routine returns in the lp a ptr
					"to the q in bfx format - length 2 words
"
	epplp	ab|0,x7			"get ptr to area to be allocated
	eax7	4,x7			"alloc 4 words
	cmpq	0,dl			"find out sign of number
	tmi	6,ic			"neg - have to negate for abs value
	stq	lp|1			"positive - just store as is
	stz	lp|2			"high order word is zero
	ldq	2,dl			"put in sign and length
	stq	lp|0
	tra	0,x0			"return
	lls	36			"bring into a
	lrs	36			"back to q, extending sign bit
	negl	0			"negate it
	lls	1			"bring high order bit into a
	qrl	1			"bring rest back without it
	stq	lp|1			"store double word result
	sta	lp|2
	ldq	=v18/-1,18/2		"load neg sign and length 2
	stq	lp|0			"store in bfx
	tra	0,x0			"return
"
"
convert_q_to_sfl:				"this routine converts the sfx in the q into an sfl
					"in the EAQ.
"
	lls	36
	lde	=35b25,du
	fad	=0.0,du
	tra	0,x0			"return
"
"
div_bb:					"this routine divides bfx bigger by bfx smaller,
					"and places the result in answer.
"
	stx0	bp|div_bb_ret		"save return address
	lxl2	bp|smallerp,*		"get high order word
	ldq	0,dl			"clear q
	lda	bp|smallerp,*x2		"get into EAQ
	lde	0,du
	fad	=0			"normalize (find # of leading zeroes)
	ste	bp|temp
	lda	bp|temp			"make it a number (it is negative)
	ars	28
	neg	0			"make it positive
	sta	bp|shift_value		"save as shift value
	epplp	bp|smallerp,*		"get ptr to value to be copied and shifted
	tsx0	div_bb_lsh		"do it
	sprilp	bp|divisorp		"store ptr to result
	epplp	bp|biggerp,*		"do same for other number
	tsx0	div_bb_lsh
	sprilp	bp|dividendp
	lxl2	bp|smallerp,*		"get len of divisor
	epplp	bp|divisorp,*x2		"get ptr to end of divisor
	sprilp	bp|v1p			"save for future reference
	epplp	lp|-1
	sprilp	bp|v2p
	stx2	bp|n
	lxl6	bp|biggerp,*		"get len of other
	adx6	1,du			"it is one greater than divisor
	stx6	bp|j			"save
	sbx6	bp|n			"calc length of result
	tmi	div_bb_zero		"divisor is bigger than dividend
	tze	div_bb_zero
	stx6	bp|m
	tsx0	alloc_bfx6		"alloc result
	sprilp	bp|answerp		"save ptr to it
	ldx6	bp|m			"store length
	sxl6	lp|0
	ldx6	bp|smallerp,*
	erx6	bp|biggerp,*
	stx6	bp|answerp,*		"store sign
"
get_qhat:
	ldx2	bp|j			"set lp->dividend
	epplp	bp|dividendp,*x2
	lda	lp|0			"calc quotient digit guess, a la Knuth.
	cmpa	bp|v1p,*
	tmi	div_bb_less
	ldq	=o377777777777
	lda	lp|-1
	tra	l3h
dec_qhat:
	ldq	bp|qhat
	sbq	1,dl
	lda	bp|rhat
l3h:	stq	bp|qhat
	adla	bp|v1p,*
	tmi	got_qhat
	sta	bp|rhat
	tra	got_rhat
div_bb_less:
	ldq	lp|-1
	qls	1
	dvf	bp|v1p,*
	sta	bp|qhat
	stq	bp|rhat
got_rhat:
	ldq	bp|qhat
	mpy	bp|v2p,*
	lls	1
	cmpa	bp|rhat
	tmi	got_qhat
	tnz	dec_qhat
	qrl	1
	cmpq	lp|-2
	tmi	got_qhat
	tnz	dec_qhat
"
got_qhat:
	eax3	0
	stz	bp|carry			"do multiply and subtract
	stz	bp|carrya
	sbx2	bp|n
	epplp	bp|dividendp,*x2
div_bb_loop:
	eax3	1,x3
	ldq	bp|divisorp,*x3
	mpy	bp|qhat
	adl	bp|carry
	lls	1
	qrl	1
	stq	bp|temp
	sta	bp|carry
	ldq	lp|-1,x3
	sblq	bp|carrya
	sblq	bp|temp
	lda	0,dl
	lls	1
	qrl	1
	stq	lp|-1,x3
	sta	bp|carrya
	cmpx3	bp|n
	tnz	div_bb_loop
	eax3	1,x3
	ldq	lp|-1,x3
	sblq	bp|carrya
	sblq	bp|carry
	lda	0,dl
	lls	1
	qrl	1
	stq	lp|-1,x3
	cmpa	0,dl
	tze	store_q
	ldq	bp|qhat			"qhat too big, so dec by one
	sbq	1,dl
	stq	bp|qhat
	eax3	0
	lda	0,dl			"add back in
div_bb_loop1:
	eax3	1,x3
	ldq	lp|-1,x3
	adlq	add_structure+1,al
	adlq	bp|divisorp,*x3
	lda	0,du
	lls	1
	qrl	1
	stq	lp|-1,x3
	cmpx3	bp|n
	tnz	div_bb_loop1
	eax3	1,x3
	ldq	lp|-1,x3
	adlq	add_structure+1,al
	lls	1
	qrl	1
	stq	lp|-1,x3
"
store_q:
	ldx2	bp|m
	lda	bp|qhat
	sta	bp|answerp,*x2
	ldx3	bp|j
	eax3	-1,x3
	stx3	bp|j
	eax2	-1,x2
	stx2	bp|m
	tnz	get_qhat
	ldx0	bp|div_bb_ret
	tra	0,x0
div_bb_zero:
	eax6	1			"result is zero
	tsx0	alloc_bfx6
	sprilp	bp|answerp
	eax2	1
	sxl2	lp|0			"store vital statistics
	ldx2	bp|smallerp,*
	erx2	bp|biggerp,*
	stx2	lp|0
	stz	lp|1
	ldx0	bp|div_bb_ret		"return
	tra	0,x0
"
"
div_bb_lsh:
	stx0	bp|div_bb_lsh_ret
	lxl6	lp|0
	sprilp	bp|div_bb_temp
	adx6	3,du
	tsx0	alloc_bfx6
	sprilp	bp|shiftp
	lxl2	bp|div_bb_temp,*
	stz	lp|0
	stz	lp|2,x2
	epplp	bp|div_bb_temp,*
	tsx0	lsh_bfx
	epplp	bp|shiftp,*
	ldx0	bp|div_bb_lsh_ret
	tra	0,x0
"
"
div_bs:					"this routine divides bfx bigger by divisor,
					"putting the quotient in result, and the
					"remainder is left in the q.
"
	lxl2	bp|biggerp,*		"load the offset of last (m.sig.) element
	sxl2	bp|resultp,*		"it is also the length of result
	lda	0,dl			"clear the remainder
div_bs_loop:
	ldq	bp|biggerp,*x2		"get next word to divide 
	qls	1			"dvf needs this shift
	dvf	bp|divisor		"do the divide of aq
	sta	bp|resultp,*x2		"store the quotient
	eax2	-1,x2			"go to next word
	tze	0,x0			"done - return
	llr	36			"move remainder to above next word
	tra	div_bs_loop		"get next word
"
"
div_by_zero:
	lda	<lisp_error_table_>|[division_by_zero]	"load error code
	tra	bad_error			"join error code
"
"
enter:					"this routine does the stuff for entry
"
	eax1	0,x7			"save where x7 was in x1
	eax7	auto_block_size,x7		"alloc the automatic variables
	eppbp	ab|0,x1			"get ptr to them in bp
	stx5	bp|num_of_args		"save x5 (number of args * -2)
	sti	bp|saved_indicators		"save the indicators
	stq	bp|function_name		"remember who we are for errors
	tra	0,x0			"return
"
"
exop_bfx:					"this routine does bfx adds and subtracts
					"lp should point to a structure in the
					"correct format.
"
	ldx2	0,du
	lda	0,du
exop_bfx_loop:
	eax2	1,x2			"get next set of words
	ldq	bp|biggerp,*x2		"get bigger one
	adlq	lp|1,al			"add carry into it (0,+1,-1)
	xec	lp|0			"do add or subtract
	lda	0,du			"clear a
	lls	1			"shift high bit into a
	qrl	1			"leave it there
	stq	bp|resultp,*x2		"store q as result
	cmpx2	bp|small_limit		"are we done this loop?
	tnz	exop_bfx_loop		"no - do next higher word
	tra	exop_bfx_check		"join ripple code at check point
exop_bfx_ripple:
	eax2	1,x2			"get next word
	ldq	bp|biggerp,*x2		"load into q
	adlq	lp|1,al			"add in carry factor
	lda	0,du			"move high bit into a
	lls	1
	qrl	1
	stq	bp|resultp,*x2		"store result
exop_bfx_check:
	cmpx2	bp|big_limit		"are we done?
	tnz	exop_bfx_ripple		"no
	eax2	1,x2			"get room for last carry
	sta	bp|resultp,*x2		"store it
	sxl2	bp|resultp,*		"store size
	tra	0,x0
"
"
float_error:
	sprilp	bp|temp			"put value in error in mkd pdl
	ldaq	bp|temp
	ora	Big_fixed,dl
	eppap	ap|2			"make room on mkd pdl
	staq	ap|-2			"put value there
	lda	<lisp_error_table_>|[unable_to_float]	"load error code
	tra	bad_error			"join error code
"
"
force_q_to_bfx:				"this routine converts the q to a bfx.
					"it assumes that it is invoked after an
					"overflow and uses the carry indicator
					"to know more about the result
					"it returns a ptr to the bfx in lp
"
	epplp	ab|0,x7			"load ptr to area to be alloced
	eax7	4,x7			"alloc the area
	trc	force_q_to_bfx_neg		"transfer if carry -> negative result
	lda	0,du			"move high order bit into a
	lls	1
	qrl	1
	stq	lp|1			"store result
	sta	lp|2
	ldq	2,dl			"set length and sign (pos)
	stq	lp|0
	tra	0,x0
force_q_to_bfx_neg:
	lda	=v36/-1			"its a large negative number
	negl	0			"get abs
	lls	1			"get second word
	qrl	1
	stq	lp|1			"store result
	sta	lp|2
	ldq	=v18/-1,18/2		"get length and sign (neg)
	stq	lp|0			"store it
	tra	0,x0
"
"
load_arg_bfx:				"this routine moves result and arg into big and small
"
	epplp	bp|resultp,*
	sprilp	bp|biggerp
	lxl2	lp|0
	stx2	bp|big_limit
	epplp	ap|0,x5*
	sprilp	bp|smallerp
	lxl2	lp|0
	stx2	bp|small_limit
	tra	0,x0
"
"
lsh_bfx:					"this routine shifts left bfx->lp shift_value places
					"and puts the answer in shiftp->bfx.  X2 says how many words.
"
	lxl3	bp|shift_value
	eppbp	bp|shiftp,*
	stz	bp|1,x2
lsh_bfx_loop:
	lda	0,dl
	ldq	lp|0,x2
	lls	1,x3
	qrl	1
	orsa	bp|1,x2
	stq	bp|0,x2
	eax2	-1,x2
	tnz	lsh_bfx_loop
	eppbp	ab|0,x1
	tra	0,x0
"
"
move_bfx:					"moves resulp->bfx to lp->bfx
					"called with tsx6, and clobbers x4, a, q
"
	eppbb	bp|resultp,*		"get pointer to bfx to be moved in bb
	ldq	bb|0			"get length
	qls	2			"convert to number of characters
	eax4	4,ql			"add allow for header. (assume not ridiculously huge)
	mlr	(pr,rl),(pr,rl)		"move the stuff
	desc9a	bb|0,x4
	desc9a	lp|0,x4
	tra	0,x6			"return
"
"
mpy_bfx:					"this routine multiplies bigger by smaller
"
	eax2	1			"load ptrs, 2 -> bigger (multiplicandd)
	eax3	1			"           3 -> smaller(multiplier)
	eax4	1			"           4 -> result (product)
	stz	bp|carry			"zero the carry
mpy_bfx_loop1:
	ldq	bp|biggerp,*x2		"load next word of multiplicand
	mpy	bp|smallerp,*x3		"do the multiply
	adl	bp|carry			"add the single word carry to the aq
	lls	1			"store the lower word
	qrl	1
	stq	bp|resultp,*x4
	eax4	1,x4			"go to next word of result
	sta	bp|carry			"store the new carry
	cmpx2	bp|big_limit		"are we done the first pass?
	tze	mpy_bfx_join		"yes
	eax2	1,x2			"no - get next word of bigger
	tra	mpy_bfx_loop1		"continue multiplying
mpy_bfx_loop2:
	ldq	bp|biggerp,*x2		"load next word of bigger
	mpy	bp|smallerp,*x3		"do mult
	adl	bp|carry			"add carry
	adl	bp|resultp,*x4		"add to result
	lls	1
	qrl	1
	stq	bp|resultp,*x4		"store low word
	eax4	1,x4			"now add high word to result
	sta	bp|carry			"store the new carry
	cmpx2	bp|big_limit		"are we done with multiplicand?
	tze	3,ic			"yes - check multiplier
	eax2	1,x2			"bump x2
	tra	mpy_bfx_loop2		"continue
mpy_bfx_join:
	lda	bp|carry			"store the carry in next word
	sta	bp|resultp,*x4
	eax4	1,x4			"bump x4 incase next x3 ->val is zero
	stz	bp|carry			"clear the carry
	eax2	1			"reset multiplicand ptr
	cmpx3	bp|small_limit		"are we done with multiplier?
	tze	mpy_bfx_done		"yes
	eax3	1,x3			"bump x3
	szn	bp|smallerp,*x3		"is multiplier zero?
	tze	mpy_bfx_join		"yes - skip the multiply
	eax4	0,x3			"product ptr starts where multiplier's is
	tra	mpy_bfx_loop2		"continue
mpy_bfx_done:
	eax4	-1,x4			"x4 is one too far
	sxl4	bp|resultp,*		"done - store length
	tra	0,x0			"return
"
"
mpy_bs:					"this routine multiplies bigger by sfx multiplier
"
	epplp	bp|biggerp,*		"get ptr to bfx
	lxl2	lp|0			"get length of bfx
	stx2	bp|big_limit		"store as loop terminater.
	eax2	0			"initialize counter
	stz	bp|carry			"clear carry
mpy_bs_loop:
	eax2	1,x2			"get next word
	ldq	lp|0,x2			"load next word
	mpy	bp|multiplier		"do the multiply
	adl	bp|carry			"add the carry
	lls	1			"get new carry
	qrl	1
	stq	bp|resultp,*x2		"store the result
	sta	bp|carry			"store the carry
	cmpx2	bp|big_limit		"are we done?
	tmi	mpy_bs_loop		"no
	eax2	1,x2			"get next result word
	sta	bp|resultp,*x2		"store the last carry
	sxl2	bp|resultp,*		"store the length
	tra	0,x0			"return
"
"
norm_a:					" normalizes A reg., returns number of significant
					" bits in Q.
	ldq	0,dl
	lde	=o106000,du		" 35.<-28.
	cmpa	0,dl			" get sign of arg
	tze	0,x0			" return if zero.
	tpl	norm_ge0			" if A < 0
	cmpa	=o400000,du		" check for bad case.
	tnz	3,ic			" and return 36
	ldq	36,dl			" in this case
	tra	0,x0
	sba	1,dl
norm_ge0:
	fad	=0.0,du			" normalize.
	ste	bp|temp			" get the exponent register
	ldq	bp|temp			" into the Q
	qrs	36-8			" shift it to correct place,
	tra	0,x0
"
"
numval:					"checks type of arg -> by x5, skipping:
					" 0 if sfx
					" 1 if sfl
					" 2 if bfx
					" 3 if bfl
					" error otherwise
					"
					"uses x2.
"
	lxl2	ap|0,x5			"load the type bits into x2
	canx2	Fixed,du			"check with all numeric types and skip
	tnz	0,x0
	canx2	Float,du
	tnz	1,x0
	canx2	Big_fixed,du
	tnz	2,x0
	tra	badarg			"ERROR
"
"
ret_to_pl1:				"this routine returns to a pl1 program -
					"it needs to have the lp set.
"
	spriap	<lisp_static_vars_>|[stack_ptr] "let pl1 prog know about stack changes
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code		"indicate that we aren't in non-pl1
	short_return
"
"
return:					"this routine is the opposite of enter
					"returned values should be in aq
"
	ldi	bp|saved_indicators		"restore the indicators
	ldx5	bp|num_of_args		"restore x5 for the next instruction
	eppap	ap|0,x5			"pop the marked stack
	epplp	bp|old_lp,*		"restore the caller's lp
	eppbp	bp|return_point,*		"get ptr to return point
	eax7	-4,x1			"pop the unmarked stack
	tra	bp|0			"return
"
"
return_0:					"returns with a zero value
"
	lda	fixnum_type,dl		"put type bits in the a
	ldq	0,dl			"load a value of zero
	tra	return			"return
"
"
return_0.0:				"returns a floating zero
	lda	flonum_type,dl
	ldq	=0.0
	tra	return
"
"
return_1:
	lda	fixnum_type,dl
	ldq	1,dl
	tra	return
"
"
return_1.0:				"returns a floating one
	lda	flonum_type,dl
	ldq	=1.0
	tra	return
"
"
return_bfx:				"gets a place for result, then returns
"
	tsx0	call_alloc_bfx		"allocate the bfx
	ldaq	bp|resultp		"get ptr to it
	ora	Big_fixed,dl		"make bignum ptr
	tra	return			"do a return
"
"
return_minus1:				"returns a minus one
	lda	fixnum_type,dl		"load type bits
	lcq	1,dl			"load the value
	tra	return			"return
"
"
return_nil:				"returns the value nil
	ldaq	ab|nil
	tra	return
"
"
return_sfl:				"returns q as an sfl
	fst	bp|temp			"store EAQ in sfl
	ldq	bp|temp			"load as one number (one word)
	lda	flonum_type,dl		"load type bits
	tra	return
"
"
return_sfx:				"returns q as an sfx
	lda	fixnum_type,dl		"load type bits
	tra	return
"
"
return_true:				"returns the value t
	ldaq	ab|true
	tra	return
"
"
rsh_bfx:					"shifts lp->bfx right shift_value
					"places, in place.
"
	lxl3	bp|shift_value		"get value to shift
	lxl2	lp|0			"get length
	stx2	bp|big_limit		"save it
	cmpx2	1,du			"rsh_bfx (1)?
	tze	rsh_bfx_1
	eax2	1			"initialize x2, word counter
	ldq	lp|0,x2			"get first word
	qls	1			"move up to block sign
rsh_bfx_loop:
	lda	lp|1,x2			"get next word
	lrl	0,x3			"do the shift
	qrl	1			"make a sign bit
	stq	lp|0,x2			"store the result
	llr	37,x3			"move what's left to the q in position
	eax2	1,x2			"get next word
	cmpx2	bp|big_limit		"are we done?
	tmi	rsh_bfx_loop		"no
	qrl	1,x3			"store last word
	stq	lp|0,x2
	tra	0,x0			"return

rsh_bfx_1:ldq	lp|1
	qrl	0,x3
	stq	lp|1
	tra	0,x0
"
"
setup_mpy_bfx:				"this routine takes bigger and smaller and sets
					"the proper variables for a mpy_bfx -
					"including allocing the result and setting
					"sign.
"
	lxl2	bp|biggerp,*		"set limits
	stx2	bp|big_limit
	lxl2	bp|smallerp,*
	stx2	bp|small_limit
	epplp	ab|0,x7			"alloc correct size result
	sprilp	bp|resultp
	eax2	2,x7
	adx2	bp|big_limit
	adx2	bp|small_limit
	anx2	-2,du
	eax7	0,x2
	ldx2	bp|biggerp,*
	erx2	bp|smallerp,*
	stx2	bp|resultp,*
	tra	0,x0
"
"
switch_bfx:				"switches bigger and smaller
"
	ldaq	bp|biggerp		"switch the ptrs
	staq	bp|temp
	ldaq	bp|smallerp
	staq	bp|biggerp
	ldaq	bp|temp
	staq	bp|smallerp
	ldaq	bp|big_limit		"load big and small limits as a unit
					"this requires them to be 2 word aligned
	llr	36			"switch their positions
	staq	bp|big_limit		"store the switched values
	lda	-1,du			"indicate that a swich was performed
	ersa	bp|switched
	tra	0,x0			"return
"
"
switch_to_lisp:				"loads registers to make a lisp environment
"
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	tra	0,x0
"
"
truncate_bfx:				"this routine sets the length of result
					"to the smallest value possible, stripping
					"off leading zeroes.  It will skip on return
					"if the result could be an sfx.
"
	lxl2	bp|resultp,*		"get length
	eax2	1,x2			"start out one ahead
truncate_bfx_loop:
	eax2	-1,x2			"go back one word
	tze	truncate_bfx_small		"all zero -> small
	szn	bp|resultp,*x2		"see if word is zero
	tze	truncate_bfx_loop		"yes, look at word before it
	sxl2	bp|resultp,*		"store new length
	cmpx2	1,du			"are we now an sfx?
	tze	1,x0			"yes
	cmpx2	2,du			"now check for -400000000000
	tnz	0,x0
	szn	bp|resultp,*
	tpl	0,x0
	lda	bp|resultp,*x2
	eax2	-1,x2
	ldq	bp|resultp,*x2
	cmpaq	=v36/1,36/0
	tze	1,x0			"skip on return if could be sfx
	tra	0,x0
truncate_bfx_small:
	ldx2	1,du			"get length of one
	sxl2	bp|resultp,*		"store it
	tra	1,x0			"skip on return
"
"
plus:					"This is the plus lsubr
	lcq	-fn_plus,dl		"remember who we are (incase of error)
	eax4	add_opcode		"since this op is table driven, load the table
plus_start:
	tsx0	enter			"set up the automatic variables
	stx4	bp|op_table		"save what type of op we are
	eax5	0,x5			"are there any arguments?
	tze	return_0			"no - return a zero
	tsx0	numval			"branch on type of first arg
	tra	plus_sfx
	tra	plus_sfl
	tra	plus_bfx
"
plus_sfx:
	ldi	nooverflow,dl		"inhibit overflow
	ldaq	ap|0,x5			"load first arg and its type bits
plus_sfx_loop:
	eax5	2,x5			"get next arg
	tze	return			"no more - return what we have in the aq
	tsx0	numval			"branch on type
	tra	plus_sfx_add
	tra	plus_sfx_sfl
	tra	plus_sfx_make_big
"
plus_sfx_add:
	xec	2,x4			"do the operation - add or subtract
	tov	2,ic			"if overflow, then switch to bignum
	tra	plus_sfx_loop		"get next arg and add it
	tsx0	force_q_to_bfx		"get ptr to q in bfx form
	sprilp	bp|resultp		"store it in resultp
	tra	plus_bfx_loop		"join bfx code
plus_sfx_make_big:
	tsx0	convert_q_to_bfx		"change to bfx
	sprilp	bp|resultp
	tra	plus_bfx_add		"join bfx code
"
plus_sfx_sfl:
	tsx0	convert_q_to_sfl		"convert the sfx to sfl
	tra	plus_sfl_add		"and join the sfl code
"
plus_sfl:
	fld	ap|1,x5			"load first arg
plus_sfl_loop:
	eax5	2,x5			"get next arg
	tze	return_sfl		"no more - return
	tsx0	numval			"branch on arg type
	tra	plus_sfl_sfx
	tra	plus_sfl_add
	tra	plus_sfl_bfx
plus_sfl_add:
	xec	6,x4			"do add or subtract
	tra	plus_sfl_loop		"get next arg
plus_sfl_sfx:
	fst	bp|temp			"save what we have
	ldq	ap|1,x5			"convert arg to sfl
	tsx0	convert_q_to_sfl
	xed	4,x4			"do operation, with optional negate
	tra	plus_sfl_loop
plus_sfl_bfx:
	fst	bp|temp			"save q
	epplp	ap|0,x5*			"get ptr to bfx
	tsx6	convert_bfx_to_sfl		"do convert
	tra	float_error		"no skip means a conversion error
	xed	4,x4			"do operation
	tra	plus_sfl_loop		"get next arg
"
plus_bfx:
	ldaq	ap|0,x5			"move ptr to 1st arg to resultp
	staq	bp|resultp
plus_bfx_loop:
	eax5	2,x5			"get next arg
	tze	return_bfx		"no more - alloc result and return
	tsx0	numval			"branch on arg type
	tra	plus_bfx_make_big
	tra	plus_bfx_sfl
	tra	plus_bfx_add
plus_bfx_add:
	stz	bp|switched		"reset check for switching (subtract needs)
	tsx0	load_arg_bfx		"move result and arg into big and small
	tsx0	compare_bfx		"compare them
	tsx0	switch_bfx		"switch if b<s
	nop	0
plus_bfx_common:
	epplp	ab|0,x7			"get ptr to area to be alloced for result
	sprilp	bp|resultp
	eax2	3,x7			"get EVEN(x7 + 3 + big_limit)
	adx2	bp|big_limit
	anx2	-2,du
	eax7	0,x2
	ldx2	bp|biggerp,*		"are signs different?
	erx2	bp|smallerp,*
	adx2	bp|op_table		"pick up what to do based on that
	epplp	1,x2*
	tsx0	exop_bfx			"do the operation
	ldx2	bp|biggerp,*		"load sign of bigger
	xec	3,x4			"change if need be
	stx2	bp|resultp,*		"store as sign of result - converting
					"to sfx takes care of minus zero
	tsx0	truncate_bfx		"can the result be truncated?
	tra	plus_bfx_loop		"get next arg
	tsx0	convert_bfx_to_sfx		"trunc skipped, so make an sfx
	tra	plus_sfx_loop		"join sfx code
plus_bfx_make_big:
	ldq	ap|1,x5			"load value from arg
	tsx0	convert_q_to_bfx		"convert to bfx
	sprilp	bp|smallerp		"store ptr to it in smaller
	ldx2	2,du
	stx2	bp|small_limit
	epplp	bp|resultp,*		"move result to bigger
	sprilp	bp|biggerp
	lxl2	lp|0
	stx2	bp|big_limit
	stz	bp|switched		"reset switching switch
	tra	plus_bfx_common		"join other code
plus_bfx_sfl:
	epplp	bp|resultp,*		"convert result to sfl
	tsx6	convert_bfx_to_sfl
	tra	float_error		"no skip=> overflow
	tra	plus_sfl_add		"join sfl code
"
"
difference:
	lcq	-fn_difference,dl		"remember who we are
	eax4	sub_opcode		"indicate that we are subtract
	tra	plus_start		"and then join the plus code
"
"
	even
add_opcode:
	arg	sub_structure
	arg	add_structure
	adq	ap|1,x5
	nop	0,du
	fad	bp|temp
	nop 	0,dl
	fad	ap|1,x5
	adq	1,dl
"
	even
sub_opcode:
	arg	add_structure
	arg	sub_structure
	sbq	ap|1,x5
	erx2	bp|switched
	fsb	bp|temp
	fneg	0
	fsb	ap|1,x5
	sbq	1,dl
add_structure:
	adlq	bp|smallerp,*x2
	dec	0
	dec	1
sub_structure:
	sblq	bp|smallerp,*x2
	dec	0
	dec	-1
"
"
times:
	lcq	-fn_times,dl		"remember who we are
	tsx0	enter			"set up the auto vars
	eax5	0,x5			"are there any args?
	tze	return_1			"no - return a one
	tsx0	numval			"branch on arg type
	tra	times_sfx
	tra	times_sfl
	tra	times_bfx
times_sfx:
	ldq	ap|1,x5			"load the first arg
times_sfx_loop:
	eax5	2,x5			"get next arg
	tze	return_sfx		"no more - done
	tsx0	numval			"branch on type of next arg
	tra	times_sfx_mpy
	tra	times_sfx_sfl
	tra	times_sfx_bfx
times_sfx_mpy:
	mpy	ap|1,x5			"do the multiply
	cmpaq	=v36/0,o36/400000000000	"check that the product is still sfx
	tpl	3,ic			"no
	cmpaq	=v36/-1,o36/400000000000
	tpl	times_sfx_loop		"ok - still sfx so continue
times_sfx_gets_big:
	tsx0	convert_aq_to_bfx		"convert result to bfx
	sprilp	bp|resultp		"store ptr to it
	tra	times_bfx_loop		"join bfx code
times_sfx_sfl:
	tsx0	convert_q_to_sfl		"convert to sfl and join them
	tra	times_sfl_mpy
times_sfx_bfx:
	epplp	ap|0,x5*			"set up for big times small
	sprilp	bp|biggerp		"move in ptr to bfx
	tra	times_bs_join		"small num is in q, so just join
"
times_sfl:
	fld	ap|1,x5			"load first arg
times_sfl_loop:
	eax5	2,x5			"get next arg
	tze	return_sfl
	tsx0	numval			"branch on arg type
	tra	times_sfl_sfx
	tra	times_sfl_mpy
	tra	times_sfl_bfx
times_sfl_mpy:
	fmp	ap|1,x5			"do the mpy
	tra	times_sfl_loop		"get next arg
times_sfl_sfx:
	fst	bp|temp			"save EAQ
	ldq	ap|1,x5			"get sfx to be made into sfl
	tsx0	convert_q_to_sfl
	fmp	bp|temp			"do the mpy
	tra	times_sfl_loop		"do again
times_sfl_bfx:
	fst	bp|temp			"save
	epplp	ap|0,x5*			"convert bfx arg to sfl
	tsx6	convert_bfx_to_sfl
	tra	float_error		"no skip - overflow
	fmp	bp|temp			"do the mpy
	tra	times_sfl_loop		"and get next arg
"
times_bfx:
	ldaq	ap|0,x5			"make first arg old result
	staq	bp|resultp
times_bfx_loop:
	eax5	2,x5			"get next arg
	tze	return_bfx		"no more - done
	tsx0	numval			"branch on type of next arg
	tra	times_bfx_sfx
	tra	times_bfx_sfl
	tra	times_bfx_mpy
times_bfx_mpy:
	tsx0	load_arg_bfx		"load result and arg into big and small
times_bfx_common:
	epplp	ab|0,x7			"get ptr to result (to be allocated)
	sprilp	bp|resultp		"store in resultp
	eax2	2,x7			"calc EVEN(x7 + big_limit + small_limit + 2)
	adx2	bp|big_limit
	adx2	bp|small_limit
	anx2	-2,du
	eax7	0,x2			"alloc the appropriate number of words
	ldx2	bp|biggerp,*		"calc sign of result
	erx2	bp|smallerp,*
	stx2	bp|resultp,*		"store it
	tsx0	mpy_bfx			"do the multiply
	tsx0	truncate_bfx		"truncate it
	tra	times_bfx_loop		"get next arg
	tsx0	convert_bfx_to_sfx		"truncate skipped => make small
	tra	times_sfx_loop		"join sfx code
times_bfx_sfx:
	ldaq	bp|resultp		"move in bignum
	staq	bp|biggerp
	ldq	ap|1,x5			"get small num
times_bs_join:
	ldx2	bp|biggerp,*		"get sign of bfx
	lls	36			"xor with sign of sfx (put in a)
	tpl	times_bs_pos		"sfx positive=> don't negate value and bfx sign
	cmpa	=o400000000000		"see if we can't negate it
	tze	times_bs_make_bb		"can't negate - go to bfx times bfx
	neg 	0			"negate the number - need abs
	erx2	-1,du			"change sign of result
times_bs_pos:
	sta	bp|multiplier		"save abs of sfx as multiplier
	lxl6	bp|biggerp,*		"get length of bfx
	eax6	1,x6			"add one for length of sfx = len result
	tsx0	alloc_bfx6		"alloc the result
	sprilp	bp|resultp		"save ptr to it
	stx2	lp|0			"save the sign
	tsx0	mpy_bs			"do the multiply
	tsx0	truncate_bfx		"try to make smaller
	tra	times_bfx_loop		"get next arg
	tsx0	convert_bfx_to_sfx		"skip => make small
	tra	times_sfx_loop
times_bs_make_bb:
	lrs	36			"put in q
	tsx0	convert_q_to_bfx		"change the sfx to a bfx
	sprilp	bp|smallerp		"setup for bfx times bfx
	lxl2	lp|0
	stx2	bp|small_limit
	lxl2	bp|biggerp,*
	stx2	bp|big_limit
	tra	times_bfx_common		"join bfx bfx code
"
times_bfx_sfl:
	epplp	bp|resultp,*		"get ptr to result to convert
	tsx6	convert_bfx_to_sfl
	tra	float_error		"error in conversion
	tra	times_sfl_mpy		"no error - join sfl code
"
"
quotient:
	lcq	-fn_quotient,dl		"remember who we are
	tsx0	enter			"set up the auto vars, etc.
	eax5	0,x5			"any args?
	tze	return_1			"no - return the identity - 1
	tsx0	numval			"branch on arg type
	tra	quot_sfx
	tra	quot_sfl
	tra	quot_bfx
"
quot_sfx:
	ldq	ap|1,x5			"pick up first arg
quot_sfx_loop:
	eax5	2,x5			"get next arg (in sfx mode)
	tze	return_sfx		"no more - done
	tsx0	numval			"branch on arg type
	tra	quot_sfx_div
	tra	quot_sfx_sfl
	tra	quot_sfx_bfx
quot_sfx_div:
	cmpq	=o400000000000		"check that won't overflow
	tnz	4,ic
	lda	=-1			"-4000000.../-1 will do that
	cmpa	ap|1,x5
	tze	quot_sfx_make_big		"go to bfx mode
	div	ap|1,x5			"do the divide
	tra	quot_sfx_loop		"get next arg
quot_sfx_make_big:
	tsx0	convert_q_to_bfx		"do the conversion
	sprilp	bp|resultp
	tra	quot_bs			"join the other code
quot_sfx_bfx:
	cmpq	=o400000000000		"are we -400.../400...?
	tnz	quot_sfx_zero		"no
	epplp	ap|0,x5*
	lda	lp|0
	ldq	lp|1
	cmpaq	=v18/0,18/2,36/0
	tnz	quot_sfx_zero
	lda	lp|2
	cmpa	1,dl
	tnz	quot_sfx_zero
	ldq	=-1
	tra	quot_sfx_loop
quot_sfx_zero:
	ldq	0,dl
	tra	quot_sfx_loop		"get next
quot_sfx_sfl:
	tsx0	convert_q_to_sfl		"change to sfl mode
	tra	quot_sfl_div
"
quot_sfl:
	fld	ap|1,x5			"load first arg
quot_sfl_loop:
	eax5	2,x5			"get next arg
	tze	return_sfl		"no more - return
	tsx0	numval			"what type is arg?
	tra	quot_sfl_sfx
	tra	quot_sfl_div
	tra	quot_sfl_bfx
quot_sfl_div:
	fdv	ap|1,x5			"do the divide
	tra	quot_sfl_loop		"get next arg
quot_sfl_sfx:
	fst	bp|temp			"save the EAQ
	ldq	ap|1,x5			"load the sfx and convert
	tsx0	convert_q_to_sfl
	fdi	bp|temp			"do the divide
	tra	quot_sfl_loop		"get next arg
quot_sfl_bfx:
	fst	bp|temp			"save
	epplp	ap|0,x5*			"get ptr to arg
	tsx6	convert_bfx_to_sfl		"and convert it to sfl
	tra	quot_sfl_bfx_overflow	"overflow
	fdi	bp|temp			"do the divide
	tra	quot_sfl_loop		"and get the next arg

quot_sfl_bfx_overflow:
	epplb	ab|system_lp,*
	link	zunderflow,<lisp_static_vars_>|[zunderflow],*	zunderflow=t?
	ldaq	lb|zunderflow,*
	cmpaq	ab|nil
	tze	float_error		no, error.
	fld	=0.0,du			yes, return 0.0
	tra	return_sfl
"
quot_bfx:
	ldaq	ap|0,x5			"make first arg old result
	staq	bp|resultp
quot_bfx_loop:
	eax5	2,x5			"get next arg
	tze	return_bfx		"no more - return
	tsx0	numval			"branch on type
	tra	quot_bs
	tra	quot_bfx_sfl
	tra	quot_bb
quot_bs:
	ldaq	bp|resultp		"divide bfx by sfx, move result to bigger
	staq	bp|biggerp
	ldx2	bp|biggerp,*		"load sign of dividend
	lda	ap|1,x5			"load divisor value
	tpl	quot_bs_join		"don't do anything if non-negative
	cmpa	=o400000000000		"see if can't take negative
	tze	quot_bs_make_bb
	neg	0			"get abs value
	erx2	-1,du			"get sign of result
quot_bs_join:
	sta	bp|divisor		"store divisor
	epplp	ab|0,x7			"get ptr to result (to be alloced)
	sprilp	bp|resultp		"store in resultp
	stx2	bp|resultp,*		"store sign
	lxl2	bp|biggerp,*		"get length of dividend
	adx2	2,du			"add one for header, and 1 to round
	anx2	-2,du			"round down to even
	stx2	bp|temp
	adx7	bp|temp			"bump x7
	tsx0	div_bs			"do the divide
	tsx0	truncate_bfx		"try to truncate
	tra	quot_bfx_loop		"get next arg
	tsx0	convert_bfx_to_sfx		"skipped, so convert to sfx
	tra	quot_sfx_loop
quot_bs_make_bb:
	lrs	36			"move into q
	tsx0	convert_q_to_bfx		"do conversion
	sprilp	bp|smallerp
	tra	quot_bb_div		"join bfx code
quot_bfx_sfl:
	epplp	bp|resultp,*		"get ptr to bfx so far
	tsx6	convert_bfx_to_sfl		"convert it
	tra	float_error		"error
	tra	quot_sfl_div		"join other code
quot_bb:
	tsx0	load_arg_bfx
quot_bb_div:
	tsx0	div_bb
	ldaq	bp|answerp
	staq	bp|resultp
	tsx0	truncate_bfx
	tra	quot_bfx_loop
	tsx0	convert_bfx_to_sfx
	tra	quot_sfx_loop
"
"
	entry	bnprint
bnprint:
	tsx0	switch_to_lisp		"setup lisp environment
	tsx0	enter			"get auto vars
	ldaq	ap|-2			"get ptr to bignum to be broken up
	staq	bp|biggerp		"store it where it can be used
"
	lda	bp|bn_pl1_radix		"load radix
	sta	bp|divisor		"store where it will be needed
	lxl6	bp|biggerp,*		"alloc result - about twice bigger in size
	stx6	bp|temp
	adx6	bp|temp
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	stz	lp|0			"make sign positive
	epplp	ab|0,x7			"get ptr to array of results
	sprilp	bp|bn_pl1_ptr
	eax7	2,x7			"bump x7
	eax3	0			"x3 is index into this array
bnprint_loop:
	tsx0	div_bs			"do the divide
	stq	bp|bn_pl1_ptr,*x3		"store the remainder
	eax3	1,x3			"bump the pointer
	canx3	1,du			"check if time to bumb x7
	tnz	2,ic
	eax7	2,x7			"bump it
	tsx0	truncate_bfx		"truncate result
	tra	bnprint_still_big		"still bignum
	eax2	1			"could be small, so are we done?
	lda	bp|resultp,*x2		"done if quotient is < radix
	cmpa	bp|bn_pl1_radix		"do the compare
	tmi	bnprint_done		"if radix>quot, then done
bnprint_still_big:
	ldaq	bp|resultp		"move result into bigger
	staq	bp|biggerp
	tra	bnprint_loop		"do again
bnprint_done:
	tsx0	convert_bfx_to_sfx		"get last word
	stq	bp|bn_pl1_ptr,*x3		"store it
	eax3	1,x3			"make x3 be length
	stz	bp|bn_pl1_length		"clear high bits
	sxl3	bp|bn_pl1_length		"store array length
	eppap	ap|-2			"clear arg
	epplp	ab|system_lp,*		"load lp
	tra	ret_to_pl1		"return
"
"
fix:
	lcq	-fn_fix,dl
	eax5	-2			"indicate that we have one arg
	tsx0	enter			"set up auto vars
	tsx0	numval			"check type of arg
	tra	fix_sfx
	tra	fix_sfl
	tra	fix_bfx
fix_sfx:
	ldaq	ap|-2			"just a straight copy
	tra	return
fix_sfl:
	fld	ap|-1			"load the value
	tmi	fix_sfl_neg		"test sign
	fcmp	=1.0			"see if it is greater than 1
	tmi	return_0			"smaller => 0
	tze	return_1			"equal => 1
	fcmp	=1.0e10			"are we sure that it can be sfx
	tmi	3,ic			"yes
	eax4	0			"load sign (0 => +)
	tra	fix_sfl_bfx		"go do bfx conversion
	ufa	=71b25,du			"convert to sfx
	tra	return_sfx
fix_sfl_neg:
	fcmg	=1.0			"see if fraction
	tze	return_minus1		"equal -1
	tmi	return_0			"is fraction
	fcmg	=1.0e10			"can it be an sfx?
	tmi	4,ic			"yes
	eax4	-1			"no, so set sign, and go to bfx
	fneg	0
	tra	fix_sfl_bfx
	ufa	=71b25,du			"do the conversion to sfx
	tra	return_sfx		"and return
fix_sfl_bfx:
	fst	bp|temp+1			"save the floating value
	eax6	5			"alloc bfx of 5 words
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	ldaq	=v36/0,36/0		"load a zero
	staq	lp|0			"zero out bfx
	staq	lp|2
	staq	lp|4
	lda	bp|temp+1			"load sfl as word, to get exp
	lrl	64			"put exp as value in q
	div	35,dl			"find how many words result will be
	eax2	0,ql			"put value in x2
	neg	0			"negate remainder
	eax3	35,al			"add to 35
	fld	bp|temp+1			"load number
	lrl	0,x3			"do the shift
	qrl	1
	sta	lp|1,x2			"store the result
	stq	lp|0,x2
	eax2	1,x2			"get bfx length
	sxl2	lp|0			"store it in bfx
	stx4	lp|0			"store sign
	tsx0	truncate_bfx		"can we be an sfx?
	tra	return_bfx		"no - return
	tsx0	convert_bfx_to_sfx		"convert
	tra	return_sfx		"return
fix_bfx:
	ldaq	ap|-2			"just return bfx given
	staq	bp|resultp
	tra	return_bfx
"
"
float:
	lcq	-fn_float,dl
	eax5	-2			"indicate that we take one arg
	tsx0	enter			"setup the bignums environment
	tsx0	numval			"branch on type
	tra	float_sfx
	tra	float_sfl
	tra	float_bfx
float_sfx:
	ldq	ap|-1			"get arg
	tsx0	convert_q_to_sfl		"do the conversion
	tra	return_sfl
float_sfl:
	ldaq	ap|-2			"just return the arg
	tra	return
float_bfx:
	epplp	ap|-2,*			"get ptr to value
	tsx6	convert_bfx_to_sfl		"do the conversion
	tra	float_error		"overflow
	tra	return_sfl		"do the return
"
"
	entry	bnread
bnread:
	tsx0	switch_to_lisp		"get lisp environment
	tsx0	enter			"get this set of routine's environment
	ldx6	bp|bn_pl1_length		"alloc bfx at least as big as array length
	stx6	bp|small_limit		"save for loop test
	tsx0	alloc_bfx6
	sprilp	bp|resultp		"store ptr in resultp
	ldq	bp|bn_pl1_ptr,*		"load first word
	tsx0	convert_q_to_bfx		"make it a bfx for rest of routine
	sprilp	bp|biggerp
	eax3	1			"init counter
bnread_loop:
	lda	bp|bn_pl1_radix		"load radix
	sta	bp|multiplier		"store as multiplier
	tsx0	mpy_bs			"mult times the accumulated result
	epplp	bp|resultp,*		"move result to bigger
	sprilp	bp|biggerp
	lda	bp|bn_pl1_ptr,*x3		"load next number to be added
	sta	bp|addend			"it is put in addend
	tsx0	add_bs			"do the add
	tsx0	truncate_bfx		"truncate result for neatness
	nop	0			"don't care if can be sfx
	epplp	bp|resultp,*		"move
	sprilp	bp|biggerp
	eax3	1,x3			"get next word
	cmpx3	bp|small_limit		"are we done?
	tnz	bnread_loop		"no
	tsx0	call_alloc_bfx		"put result into lisp space
	eppap	ap|2			"get place on mrkd stack for result
	ldaq	bp|resultp		"put bignum ptr there
	ora	Big_fixed,dl
	staq	ap|-2
	epplp	ab|system_lp,*		"get ready to return
	tra	ret_to_pl1		"do it
"
"
add1:
	lcq	-fn_add1,dl
	eax4	add_opcode		"indicate that we will do adds
add1_enter:
	eax5	-2			"we are called with one arg
	tsx0	enter			"set up auto vars
	tsx0	numval			"check type of arg
	tra	add1_sfx
	tra	add1_sfl
	tra	add1_bfx
add1_sfx:
	ldi	nooverflow,dl		"mask overflows
	ldq	ap|-1			"load value
	xec	7,x4			"add or subtract one
	tov	2,ic			"check for overflow
	tra	return_sfx		"done
	tsx0	force_q_to_bfx		"change to bfx
	sprilp	bp|resultp
	tra	return_bfx		"done
add1_sfl:
	fld	=1.0			"get the one to add or subtract
	fst	bp|temp			"save it
	fld	ap|-1			"load value to be add/sub to
	xec	4,x4			"do the operation
	tra	return_sfl		"done
add1_bfx:
	stx4	bp|op_table		"we will use the code of plus_bfx
	epplp	ap|-2,*			"get bfx value setup like plus
	sprilp	bp|biggerp
	stz	bp|switched
	lxl2	bp|biggerp,*
	stx2	bp|big_limit
	epplp	bfx_one
	sprilp	bp|smallerp
	eax2	1
	stx2	bp|small_limit
	tra	plus_bfx_common
"
	even
bfx_one:
	vfd	18/0,18/1
	dec	1
"
"
sub1:
	lcq	-fn_sub1,dl
	eax4	sub_opcode
	tra	add1_enter
"
"
minus:
	lcq	-fn_minus,dl
	eax5	-2			"we have one arg
	tsx0	enter			"start
	tsx0	numval			"branch on type
	tra	minus_sfx
	tra	minus_sfl
	tra	minus_bfx
minus_sfx:
	lda	ap|-1			"load value
	lrs	36			"put into AQ
	negl	0			"do tbe minus
	cmpaq	=v36/0,o36/400000000000	"check that it hasn't become a bfx
	tnz	return_sfx
	tsx0	convert_aq_to_bfx		"it has - change
	sprilp	bp|resultp
	tra	return_bfx
minus_sfl:
	fld	ap|-1			"load the value
	fneg	0			"negate it
	tra	return_sfl
minus_bfx:
	ldaq	ap|-2			"copy bfx
	staq	bp|resultp
	tsx0	call_alloc_bfx
	eax2	-1			"negate it
	ersx2	bp|resultp,*
	tsx0	truncate_bfx		"check for -400000000000
	tra	minus_bfx_big
	tsx0	convert_bfx_to_sfx		"convert to sfx
	tra	return_sfx
minus_bfx_big:
	ldaq	bp|resultp		"setup return
	ora	Big_fixed,dl
	tra	return
"
"
abs:
	lcq	-fn_abs,dl
	eax5	-2			"we have one arg
	tsx0	enter			"get environment
	tsx0	numval			"branch on arg type
	tra	abs_sfx
	tra	abs_sfl
	tra	abs_bfx
abs_sfx:
	lda	ap|-1			"get arg
	lrs	36			"make 2 words
	tpl	return_sfx		"do abs operation
	negl	0
	cmpaq	=v36/0,o36/400000000000
	tnz	return_sfx
	tsx0	convert_aq_to_bfx
	sprilp	bp|resultp
	tra	return_bfx
abs_sfl:
	fld	ap|-1			"load value
	tpl	return_sfl		"do abs operation
	fneg	0
	tra	return_sfl
abs_bfx:
	szn	ap|-2,*			"check sign
	tmi	abs_bfx_minus		"branch if negative
	ldaq	ap|-2			"return argument as is
	tra	return
abs_bfx_minus:
	ldaq	ap|-2
	staq	bp|resultp		"copy and change sign
	tsx0	call_alloc_bfx
	eax2	0
	ansx2	bp|resultp,*
	ldaq	bp|resultp
	ora	Big_fixed,dl
	tra	return			"return
"
"
minusp:
	lcq	-fn_minusp,dl
	eax5	-2			"we have one arg
	tsx0	enter			"do entry sequence
	tsx0	numval			"branch to code suitable for arg type
	tra	minusp_sfx
	tra	minusp_sfl
	tra	minusp_bfx
minusp_sfx:
	szn	ap|-1			"test sign
	tmi	return_true		"return verdict
	tra	return_nil
minusp_sfl:
	fszn	ap|-1
	tmi	return_true
	tra	return_nil
minusp_bfx:
	szn	ap|-2,*
	tmi	return_true
	tra	return_nil
"
"
plusp:
	lcq	-fn_plusp,dl
	eax5	-2			"we have 2 args
	tsx0	enter			"enter
	tsx0	numval			"dispatch
	tra	plusp_sfx
	tra	plusp_sfl
	tra	plusp_bfx
plusp_sfx:
	szn	ap|-1
	tmi	return_nil		"tell verdict
	tze	return_nil
	tra	return_true
plusp_sfl:
	fszn	ap|-1
	tmi	return_nil
	tze	return_nil
	tra	return_true
plusp_bfx:
	szn	ap|-2,*
	tmi	return_nil
	tra	return_true		"can't have zero bfx
"
"
max:
	lcq	-fn_max,dl
	eax4	max_table			"set up max xec table
max_start:
	tsx0	enter			"set up environment
	tsx0	numval			"branch on arg type
	tra	max_sfx
	tra	max_sfl
	tra	max_bfx
max_sfx:
	ldaq	ap|0,x5			"load first arg
max_sfx_loop:
	eax5	2,x5			"get next arg
	xec	1,x4
	tsx0	numval			"branch on type of next arg
	tra	max_sfx_sfx
	tra	max_sfx_sfl
	tra	max_sfx_bfx
max_sfx_sfx:
	cmpq	ap|1,x5			"do the comparison
	xec	0,x4			"what to do is table driven
	ldq	ap|1,x5			"load other value
	tra	max_sfx_loop
max_sfx_sfl:
	tsx0	convert_q_to_sfl		"convert to sfl
	tra	max_sfl_sfl		"join that code
max_sfx_bfx:
	tsx0	convert_q_to_bfx		"go to bfx mode
	sprilp	bp|biggerp
	tra	max_bfx_bfx
max_sfl:
	fld	ap|1,x5			"load initial value
max_sfl_loop:
	eax5	2,x5			"get next arg
	xec	5,x4
	tsx0	numval			"branch on type
	tra	max_sfl_sfx
	tra	max_sfl_sfl
	tra	max_sfl_bfx
max_sfl_sfx:
	fst	bp|temp			"save old value
	ldq	ap|1,x5			"get sfx value to be made sfl
	tsx0	convert_q_to_sfl		"convert it
max_sfl_sfx_cmp:
	fcmp	bp|temp			"compare with old value
	xec	2,x4
	fld	bp|temp			"switch to old value
	xec	3,x4
max_sfl_sfl:
	fcmp	ap|1,x5			"do the compare
	xec	4,x4
	fld	ap|1,x5
	tra	max_sfl_loop
max_sfl_bfx:
	fst	bp|temp			"save old value
	epplp	ap|0,x5*			"try to convert new value to sfl
	tsx6	convert_bfx_to_sfl
	tra	float_error
	tra	max_sfl_sfx_cmp		"do the compare
max_bfx:
	ldaq	ap|0,x5			"get initial value
	staq	bp|biggerp
max_bfx_loop:
	ldaq	bp|biggerp
	staq	bp|resultp
	eax5	2,x5			"get next arg
	xec	9,x4
	tsx0	numval			"check type
	tra	max_bfx_sfx
	tra	max_bfx_sfl
	tra	max_bfx_bfx
max_bfx_sfx:
	ldq	ap|1,x5			"get value
	tsx0	convert_q_to_bfx		"make it big
	sprilp	bp|smallerp
	tra	max_bfx_bfx_cmp
max_bfx_sfl:
	epplp	bp|biggerp,*		"get value so far
	tsx6	convert_bfx_to_sfl		"convert to sfl
	tra	float_error
	tra	max_sfl_sfl		"join sfl code
max_bfx_bfx:
	ldaq	ap|0,x5			"get new value
	staq	bp|smallerp
max_bfx_bfx_cmp:
	tsx0	compare_signed_bfx
	xec	6,x4
	xec	7,x4
	xec	8,x4
max_bfx_bfx_switch:
	tsx0	switch_bfx		"change bigger and smaller
	tra	max_bfx_loop		"continue
"
max_table:
	tpl	max_sfx_loop		" 0
	tze	return_sfx		" 1
	tpl	max_sfl_loop		" 2
	tra	max_sfl_loop		" 3
	tpl	max_sfl_loop		" 4
	tze	return_sfl		" 5
	tra	max_bfx_bfx_switch		" 6
	tra	max_bfx_loop		" 7
	tra	max_bfx_loop		" 8
	tze	return_bfx		" 9
"
"
min:
	lcq	-fn_min,dl
	eax4	min_table
	tra	max_start			"set up and join max
"
min_table:
	tmi	max_sfx_loop		" 0
	tze	return_sfx		" 1
	tmi	max_sfl_loop		" 2
	tra	max_sfl_loop		" 3
	tmi	max_sfl_loop		" 4
	tze	return_sfl		" 5
	tra	max_bfx_loop		" 6
	tra	max_bfx_loop		" 7
	tra	max_bfx_bfx_switch		" 8
	tze	return_bfx		" 9
"
"
lessp:
	lcq	-fn_lessp,dl
	eax4	lessp_table
	tra	max_start
"
lessp_table:
	tpl	return_nil		" 0
	tze	return_true		" 1
	xed	lessp_table_2		" 2
	tra	return_nil		" 3
	tpl	return_nil		" 4
	tze	return_true		" 5
	tra	max_bfx_bfx_switch		" 6
	tra	return_nil		" 7
	tra	return_nil		" 8
	tze	return_true		" 9
	even
lessp_table_2:
	tze	return_nil
	tpl	max_sfl_loop
"
"
greaterp:
	lcq	-fn_greaterp,dl
	eax4	greaterp_table		"load table ptr and join max
	tra	max_start
"
greaterp_table:
	xed	greaterp_table_0		" 0
	tze	return_true		" 1
	tmi	max_sfl_loop		" 2
	tra	return_nil		" 3
	xed	greaterp_table_4		" 4
	tze	return_true		" 5
	tra	return_nil		" 6
	tra	return_nil		" 7
	tra	max_bfx_bfx_switch		" 8
	tze	return_true		" 9
	even
greaterp_table_0:
	tmi	return_nil
	tze	return_nil
greaterp_table_4:
	tmi	return_nil
	tze	return_nil
"
"
remainder:
	lcq	-fn_remainder,dl
	eax5	-4			"we have 2 args
	tsx0	enter			"set up environment
	tsx0	numval			"test type of first arg
	tra	rem_sfx
	tra	badarg
	tra	rem_bfx
rem_sfx:
	eax5	-2			"check second arg
	tsx0	numval
	tra	rem_sfx_sfx
	tra	badarg
	tra	rem_sfx_bfx
rem_sfx_sfx:
	ldq	ap|-3			"get first number
	cmpq	=o400000000000		"check for -400.../-1
	tnz	4,ic
	lda	=-1
	cmpa	ap|-1
	tze	rem_sfx_make_big		"need bfx arith.
	div	ap|-1			"do the division
	lrs	36			"get the remainder in proper place
	tra	return_sfx		"return
rem_sfx_make_big:
	tsx0	convert_q_to_bfx
	tra	rem_bfx_sfx_start		"join bfx code
rem_sfx_bfx:
	ldq	ap|-3			"check for -400.../400...
	cmpq	=o400000000000
	tnz	rem_sfx_bfx_rem
	epplp	ap|-2,*
	lda	lp|0
	ldq	lp|1
	cmpaq	=v18/0,18/2,36/0
	tnz	rem_sfx_bfx_rem
	lda	lp|2
	cmpa	1,dl
	tnz	rem_sfx_bfx_rem
	tra	return_0			"rem(-400.../400...) = 0
rem_sfx_bfx_rem:
	ldq	ap|-3			"the dividend is the remainder
	tra	return_sfx
rem_bfx:
	eax5	-2			"look at second arg
	tsx0	numval
	tra	rem_bfx_sfx
	tra	badarg
	tra	rem_bfx_bfx
rem_bfx_sfx:
	epplp	ap|-4,*			"get ptr to first arg
rem_bfx_sfx_start:
	sprilp	bp|biggerp		"store it
	lda	ap|-1			"get divisor
	tpl	rem_bfx_sfx_join		"get abs
	cmpa	=o400000000000		"is it too big?
	tze	rem_bfx_sfx_expand
	neg	0
rem_bfx_sfx_join:
	sta	bp|divisor		"store as divisor
	lxl6	lp|0			"quotient is of the size of the dividend
	tsx0	alloc_bfx6		"alloc the result
	sprilp	bp|resultp
	tsx0	div_bs			"do the division
	lda	0			"remainder is in q
	szn	bp|biggerp,*		"sgn(rem) = sgn(dividend)
	tpl	2,ic
	negl	0
	tra	return_sfx		"return
rem_bfx_sfx_expand:
	lrs	36			"put it in the q
	tsx0	convert_q_to_bfx		"convert to bfx
	tra	rem_bfx_bfx_start		"join bfx bfx code
rem_bfx_bfx:
	epplp	ap|-2,*			"get ptr to second arg
rem_bfx_bfx_start:
	sprilp	bp|smallerp		"store it
	epplp	ap|-4,*			"get ptr to first
	sprilp	bp|biggerp		"store it, too
	tsx0	div_bb			"do the divide
	ldx2	bp|n			"get length of divisor
	sxl2	bp|dividendp,*		"store as length of remainder
	ldx2	bp|biggerp,*		"get sign of dividend
	stx2	bp|dividendp,*		"it is sign of remainder
	epplp	bp|dividendp,*		"get ptr to it
	sprilp	bp|resultp		"store in result
	tsx0	rsh_bfx			"shift right to normalize result
	tsx0	truncate_bfx		"make as small as possible
	tra	return_bfx		"that's it
	tsx0	convert_bfx_to_sfx		"skip => can be sfx
	tra	return_sfx
"
"
expt:
	lcq	-fn_expt,dl
	eax5	-4			"we have two args
	tsx0	enter			"enter
	eax5 	-2			"look at second arg
	tsx0	numval
	tra	expt_x_sfx
	tra	expt_x_sfl
	tra	expt_x_bfx
expt_x_sfx:
	eax5	-4			"look at other arg
	tsx0	numval
	tra	expt_sfx_sfx
	tra	expt_sfl_sfx
	tra	expt_bfx_sfx
expt_sfx_sfx:
	szn	ap|-1			"to what are we raising it?
	tze	return_1			"x**0 is 1
	tmi	badarg			"only positive exponents allowed
	ldq	ap|-3			"get base
	tze	return_0			"zero to anything but zer o is zero
	cmpq	1,dl			"one to anything but zero is one
	tze	return_1
	cmpq	=-1			"minus one is almost as easy
	tnz	expt_sfx_sfx_nmo		"nmo => not minus one
	lda	ap|-1			"load power
	cana	1,dl			"test for even/odd
	tnz	2,ic			"transfer if odd (leaving -1 in q)
	ldq	1,dl
	tra	return_sfx
expt_sfx_sfx_nmo:
	lda	ap|-1			"load power
	cmpa	1,dl			"special cas e one
	tze	return_sfx
	sta	bp|n			"save exponent
	stq	bp|m			"save base as initial value to be squared
	ldq	1,dl			"initial result
	stq	bp|j			" j is the partial result
expt_sfx_sfx_loop:
	lda	bp|n			"get the exponent
	cana	1,dl			"is it odd?
	tze	expt_sfx_sfx_even
	ldq	bp|j
	mpy	bp|m			"multiply accumulated power * partial result
	tsx0	check_aq			"is it still small?
	tra	expt_sfx_sfx_big1		"no
	stq	bp|j			"store as new partial result
expt_sfx_sfx_even:
	lda	bp|n			"ge t the exponent
	ars	1			"get next bit
	tze	expt_sfx_sfx_done		"zero - done
	sta	bp|n			"save it
	ldq	bp|m			"get next power
	mpy	bp|m
	tsx0	check_aq
	tra	expt_sfx_sfx_big2
	stq	bp|m
	tra	expt_sfx_sfx_loop		"do next
expt_sfx_sfx_done:
	ldq	bp|j			"get result
	tra	return_sfx		"return
expt_sfx_sfx_big1:
	stx7	bp|initial_value		"need to remember where stack was
	tsx0	convert_aq_to_bfx		"change j and m to bfx and join bfx
	sprilp	bp|presultp
	ldq	bp|m
	tsx0	convert_q_to_bfx
	sprilp	bp|powerp
	tra	expt_bfx_sfx_even
expt_sfx_sfx_big2:
	stx7	bp|initial_value		"remember where stack was
	staq	bp|temp			"want j stored before m
	ldq	bp|j
	tsx0	convert_q_to_bfx
	sprilp	bp|presultp
	ldaq	bp|temp
	tsx0	convert_aq_to_bfx
	sprilp	bp|powerp
	tra	expt_bfx_sfx_loop
expt_sfl_sfx:
	lda	ap|-1			"to what are we raising it?
	tze	return_1.0		"x**0 is one, floating point
	sta	bp|n
	tpl	expt_sfl_sfx_plus		handle negative powers here
	neg	0
	sta	bp|n
	fld	=1.0,du			"get inverse of base
	fdv	ap|-3
	tra	2,ic			"and store as base
expt_sfl_sfx_plus:
	fld	ap|-3			"get base
	fst	bp|m			"save as multiplier
	fld	=1.0,du			"get initial partial result
	fst	bp|j			"save it
expt_sfl_sfx_loop:
	lda	bp|n			"is the current power value even?
	cana	1,dl
	tze	expt_sfl_sfx_even		"yes
	fld	bp|j			"odd => p. res. <- p. res. * multiplier
	fmp	bp|m
	fst	bp|j
expt_sfl_sfx_even:
	lda	bp|n			"get next bit of power
	ars	1
	tze	expt_sfl_sfx_done		"no more one bits => done
	sta	bp|n			"save power
	fld	bp|m			"square multiplier
	fmp	bp|m
	fst	bp|m
	tra	expt_sfl_sfx_loop		"do again
expt_sfl_sfx_done:
	fld	bp|j
	tra	return_sfl

expt_x_sfl:
	eax5	-4			"look at other arg
	tsx0	numval
	tra	expt_sfx_sfl
	tra	expt_sfl_sfl
	tra	badarg			"bignum to float power not supported

expt_sfx_sfl:
expt_sfl_sfl:		"hard cases - call PL/I support procedure

	ldi	bp|saved_indicators		flush ourselves
	ldx5	bp|num_of_args
	eppap	ap|4,x5			leave just our 2 args on stack
	eax7	0,x1			flush all but caller's lp and bp

	spriap	<lisp_static_vars_>|[stack_ptr]   now enter PL/I mode
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	push
	eppap	<lisp_subr_tv_>|[..lisp..]
	spriap	sp|22
	eppap	null_arg_list
	short_call <lisp_trig_>|[expt_assistance]
	eppbp	sp|16,*			pop stack
	sprisp	sb|20
	eppsp	bp|0
	eppap	<lisp_static_vars_>|[stack_ptr],*
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code

	ldaq	ap|-2
	eppap	ap|-2
	epplp	ab|old_lp,x7*
	eppbp	ab|return_point,x7*
	eax7	-4,x7
	tra	bp|0

	even
null_arg_list:
	oct	4,0

expt_bfx_sfx:
	szn	ap|-1			"to what are we raising it?
	tze	return_1			"x**0 is 1
	tmi	badarg			"only positive exponents allowed
	lda	ap|-1			"check if x**1
	cmpa	1,dl
	tnz	3,ic
	ldaq	ap|-4			"identity
	tra	return
	sta	bp|n			"save exponent
	stx7	bp|initial_value		"remember where umstk was
	ldq	1,dl			"initial partial result is one
	tsx0	convert_q_to_bfx
	sprilp	bp|presultp		"move base to power
	ldaq	ap|-4
	staq	bp|resultp
	lxl6	bp|resultp,*
	tsx0	alloc_bfx6
	sprilp	bp|powerp
	tsx6	move_bfx
expt_bfx_sfx_loop:
	lda	bp|n			"get exponent
	cana	1,dl			"was it odd or even?
	tze	expt_bfx_sfx_even		"no
	ldaq	bp|presultp		"presult <= presult * power
	staq	bp|smallerp
	ldaq	bp|powerp
	staq	bp|biggerp
	tsx0	setup_mpy_bfx
	tsx0	mpy_bfx
	tsx0	truncate_bfx
	nop	0,dl
	ldaq	bp|resultp
	staq	bp|presultp
expt_bfx_sfx_even:
	lda	bp|n			"get exponent
	ars	1			"get next bit
	tze	expt_bfx_sfx_done		"zero - done
	sta	bp|n			"save exponent
	ldaq	bp|powerp			"square power
	staq	bp|smallerp
	staq	bp|biggerp
	tsx0	setup_mpy_bfx
	tsx0	mpy_bfx
	tsx0	truncate_bfx
	nop	0,dl
	ldaq	bp|resultp
	staq	bp|powerp
	ldx2	bp|initial_value		"is presult at the lowest place in umstk?
	cmpx2	bp|presultp+1
	tze	expt_bfx_sfx_copy_p		"yes
	ldaq	bp|presultp		"move it to lowest place
	staq	bp|resultp
	epplp	ab|0,x2
	sprilp	bp|presultp
	tsx6	move_bfx
expt_bfx_sfx_copy_p:
	lxl2	bp|presultp,*		"how low can we move power?
	eax2	2,x2
	adx2	bp|initial_value
	anx2	-2,du
	epplp	ab|0,x2
	ldaq	bp|powerp
	staq	bp|resultp		"move it
	sprilp	bp|powerp
	tsx6	move_bfx
	lxl2	bp|powerp,*		"truncate stack
	eax2	2,x2
	anx2	-2,du
	adx2	bp|powerp+1
	eax7	0,x2
	tra	expt_bfx_sfx_loop
expt_bfx_sfx_done:
	ldaq	bp|presultp		"done - get result
	staq	bp|resultp
	tra	return_bfx		"done
expt_x_bfx:
	eax5	-4			"look at first arg
	tsx0	numval
	tra	expt_sfx_bfx
	tra	expt_sfl_bfx
	tra	badarg
expt_sfx_bfx:
	eax5	-2			"checking second arg's applicability to first - so err on 2nd
	ldq	ap|-3			"get the base
	tze	return_0			"0**x is zero (x bfx)
	cmpq	1,dl			"1**x is 1
	tze	return_1
	cmpq	=-1			"is it -1?
	tnz	badarg			"that's the last legal one
	eax2	1			"check for even odd
	lda	ap|-2,*x2
	cana	1,dl
	tze	return_1
	tra	return_sfx		"-1 left in q
expt_sfl_bfx:
	eax5	-2			"similar to sfx_bfx
	fld	ap|-3
	tze	return_0.0
	fcmp	=1.0,du
	tze	return_1.0
	fcmp	=-1.0,du
	tnz	badarg
	eax2	1
	lda	ap|-2,*x2
	cana	1,dl
	tze	return_1.0
	fld	=-1.0,du
	tra	return_sfl
"
"
haipart:	lcq	-fn_haipart,dl
	eax5	-4
	tsx0	enter
	eax5	-2
	tsx0	numval			" check second arg type.
	tra	haipart_ok
	tra	badarg
	tra	badarg

haipart_ok:
	eax5	-4
	tsx0	numval			" branck on first arg type.
	tra	haipart_sfx
	tra	badarg
	tra	haipart_bfx

haipart_sfx:
	lda	ap|1,x5			" get first argument into A
	tsx0	norm_a			" and get number of significant bits in it.
	lls	36			" move length to A,
	ldq	ap|1,x5			" and get argument 1.
	tpl	3,ic			" if negative, make positive
	erq	=-1			" avoiding fixedoverflow
	adlq	1,dl		" by negating with two instructions.
	cmg	ap|3,x5			" compare length to |arg 2|
	tze	simple_haipart_sfx		" if length <= |arg 2|
	tmi	simple_haipart_sfx

	szn	ap|3,x5			" get sign of second arg.
	tze	return_0			" if second arg 0, the result is 0.
	tmi	haipart_sfx_rem		" if negative, do remainder
	sba	ap|3,x5			" get power of 2 to divide by
	qrl	0,al			" shift down top part of word.
	tra	return_sfx

haipart_sfx_rem:
	lda	36,dl			" get amount to delete from front
	ada	ap|3,x5			" which is 36-number of bits wanted.
	qls	0,al
	qrl	0,al
	tra	return_sfx

simple_haipart_sfx:				" return absolute value, which is in q.
	cmpq	=o400000,du		" check for screw case, which is bignum.
	tnz	return_sfx		" otherwise return small number.
	epplp	ab|0,x7			" get space for bignum.
	eax7	4,x7			" on unmarked stack
	lda	2,dl			" 2 words long,
	sta	lp|0
	stz	lp|1			" a zero word, and
	lda	1,dl			" a one word
	sta	lp|2
	sprilp	bp|resultp		" set result
	tra	return_bfx		" and return bignum.


"
"
"
haipart_bfx:
	epplp	ap|0,x5*			" get pointer to first argument.
	lxl2	lp|0			" and length.
	lda	lp|0,x2			" get last word
	tsx0	norm_a			" count number of bits in it
	stq	bp|temp			" and save the count
	eaq	-1,x2			" get number of whole words in argument
	qrs	18
	mpy	35,dl			" get length in bits
	adq	bp|temp			" ...

	lls	36			" compare bit length
	cmg	ap|3,x5			" with secons argument.
	tmi	simple_haipart_bfx		" if second arg specifies more bits,
	tze	simple_haipart_bfx	" just do the right thing
	szn	ap|3,x5			" check whether to do remainder
	tze	return_0			" return zero if no bits asked for
	tpl	3,ic			" if remainder,
	lca	ap|3,x5			" get number of bits.
	tra	2,ic
	sba	ap|3,x5			" else subtract 2nd arg.

	lrl	36			" determine how many bits are to be divided off the right
	div	35,dl			" A contains number of bits,
					" Q contains number of whole words.

	szn	ap|3,x5			" check again whether to remainder
	tmi	haipart_bfx_rem

	sta	bp|shift_value
	qls	18
	stq	bp|temp			" savenumber of words to truncate from right.
	lxl6	lp|0			" compute length of result
	sbx6	bp|temp			" by subtracting off number of words truncated.
	stx6	bp|temp+1			" save size in words of result
	ldx3	bp|temp			" get offset for mlr below
	tsx0	alloc_bfx6		" allocate result on stack
	sprilp	bp|resultp		" and save location.
	ldx2	bp|temp+1			" set the length of the result.
	sxl2	lp|0			" note that the sign is zero.
	eppbb	ap|0,x5*			" bb -> place copied from.
	eppbb	bb|0,x3			" offset by number of words dropped
	eaq	0,x2			" qu := # words to copy (not header)
	qls	2			" convert # words to # characters
	mlr	(pr,rl),(pr,rl)
	desc9a	bb|1,qu
	desc9a	lp|1,qu
	tsx0	rsh_bfx			" shift bfx right by amount required.
	tsx0	truncate_bfx
	tra	return_bfx
	tsx0	convert_bfx_to_sfx	" truncate skipped, so make sfx
	tra	return


haipart_bfx_rem:				" remainder operation.
	sba	36,dl
	neg	0			" get amount to delete from high order word.
	sta	bp|shift_value
	eax6	1,ql			" allocate this many words.
	stx6	bp|temp+1
	tsx0	alloc_bfx6		" allocate the bfx on stack.
	sprilp	bp|resultp
	ldx2	bp|temp+1
	sxl2	lp|0			" set length of result.

	eppbb	ap|0,x5*			" get pointer to argument.
	eaq	0,x2			" compute length of stuff after header, in characters
	mpy	4,dl
	mlr	(pr,rl),(pr,rl)
	desc9a	bb|1,qu
	desc9a	lp|1,qu

	lda	lp|0,x2			" get high order word
	lxl3	bp|shift_value		" get amount to delete
	als	0,x3
	arl	0,x3
	sta	lp|0,x2			" put back word after deleteion.

	tsx0	truncate_bfx
	tra	return_bfx
	tsx0	convert_bfx_to_sfx
	tra	return

simple_haipart_bfx:
	ldaq	ap|0,x5			" get first arg.
	szn	lp|0			" check its sign,
	tpl	return			" return the arg as result.
	staq	bp|resultp		" set up to cpy to result
	tsx0	call_alloc_bfx
	eax2	0			" to set sign.
	stx2	bp|resultp,*
	ldaq	bp|resultp		" load the name of the result
	ora	Big_fixed,dl
	tra	return			" and return
"
"
"
"
"
gcd:
	lcq	-fn_gcd,dl		"load type code of gcd
	eax5	-4			"we are a subr with 2 args
	tsx0	enter			"set up environment
	tsx0	numval			"look at first arg
	tra	gcd_sfx
	tra	badarg
	tra	gcd_bfx
gcd_sfx:
	lda	ap|-3			"look at first arg
	tsx0	abs_sfx_a_to_q		"get abs of first arg
	tra	gcd_bfx_join		"if too big, join big code
	stq	bp|divisor		"save it
	eax5	-2			"check second arg
	tsx0	numval
	tra	gcd_ss
	tra	badarg
	tra	gcd_sb
gcd_ss:
	lda	ap|-1			"load second arg
	tsx0	abs_sfx_a_to_q		"get abs
	tra	gcd_sb_join		"too big
	szn	bp|divisor		"test for zero operands => return abs of other
	tze	return_sfx		"answer is in q already
	cmpq	0,dl			"test other one
	tnz	gcd_ss_loop
	ldq	bp|divisor
	tra	return_sfx
gcd_ss_loop:
	div	bp|divisor		"get remainder of (q) and divisor
gcd_ss_loop1:
	ldq	bp|divisor 		"replace (q) with other value
	sta	bp|divisor		"replace other with remainder
	cmpa	0,dl			"if remainder was zero, done, otherwise, loop
	tnz	gcd_ss_loop
	tra	return_sfx		"old other value (in q now) is result
gcd_sb:
	epplp	ap|-2,*			"get ptr to big arg
gcd_sb_join:
	sprilp	bp|biggerp		"save it
gcd_sb_do:
	szn	bp|divisor		"test smallnum for 0 (big can't be zero)
	tze	gcd_bs0
	lxl6	bp|biggerp,*		"alloc space for quotient, which we ignore
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	tsx0	div_bs			"do a divide
	lls	36			"put in the a the remainder (now in q)
	tra	gcd_ss_loop1		"join other code
gcd_bfx:
	epplp	ap|-4,*			"get ptr to big num
gcd_bfx_join:
	sprilp	bp|biggerp		"store the ptr to big num
	eax5	-2			"look at second arg
	tsx0	numval
	tra	gcd_bs
	tra	badarg
	tra	gcd_bb
gcd_bs:
	lda	ap|-1			"get small num
	tsx0	abs_sfx_a_to_q
	tra	gcd_bb_join
	stq	bp|divisor		"save it
	tra	gcd_sb_do			"join other big/small code
gcd_bs0:
	epplp	bp|biggerp,*		"get copy of big arg, and abs of it
	sprilp	bp|resultp
	tsx0	call_alloc_bfx		"get copy into lisp space
	eax2	0			"set sign to plus
	stx2	bp|resultp,*
	ldaq	bp|resultp		"set up return
	ora	Big_fixed,dl
	tra	return
gcd_bb:
	epplp	ap|-2,*			"get ptr to second arg
gcd_bb_join:
	sprilp	bp|smallerp		"save it
	lxl2	lp|0			"make sure bigger is bigger
	stx2	bp|small_limit
	lxl2	bp|biggerp,*
	stx2	bp|big_limit
	tsx0	compare_bfx
	tsx0	switch_bfx
	nop	0,dl
	nop	0,dl
	ldx6	bp|big_limit		"put bigger of two in u, smaller in v
	tsx0	alloc_bfx6
	sprilp	bp|up
	ldaq	bp|biggerp
	staq	bp|resultp
	tsx6	move_bfx
	ldx6	bp|small_limit
	tsx0	alloc_bfx6
	sprilp	bp|vp
	ldaq	bp|smallerp
	staq	bp|resultp
	tsx6	move_bfx
	eax2	0			"set signs to zero - i.e. get abs
	stx2	bp|up,*
	stx2	bp|vp,*
	stx7	bp|initial_value		"save stack end - so we can truncate garbage
gcd_bb_l1:
	lda	bp|vp,*			"check that we don't have to go to gcd_bs
	cmpa	1,dl			"is length 1?
	tze	gcd_bb_to_bs
	cmpa	bp|up,*			"make sure lengths are same (sign is 0, so lda)
	tnz	gcd_bb_doremain		"if not equal, then make like Euclid
	ldq	bp|up,*al			"high order word is used for quicky calculation
	stq	bp|uh			"u hat
	ldq	bp|vp,*al
	stq	bp|vh			"v hat
	ldq	1,dl			"set A,D = 1
	stq	bp|A
	stq	bp|D
	stz	bp|B			"and B, C = 0
	stz	bp|C
gcd_bb_l2:
	ldq	bp|vh			"follow Lehmer's alg in Knuth
	adlq	bp|C
	tze	gcd_bb_l4
	stq	bp|temp
	ldq	bp|uh
	adlq	bp|A
	tmi	gcd_bb_l4			"overflow
	div	bp|temp
	stq	bp|q
	ldq	bp|vh
	adlq	bp|D
	tze	gcd_bb_l4
	tmi	gcd_bb_l4
	stq	bp|temp
	ldq	bp|uh
	adlq	bp|B
	div	bp|temp
	cmpq	bp|q
	tnz	gcd_bb_l4
gcd_bb_l3:
	mpy	bp|C
	negl	0
	adl	bp|A
	lda	bp|C
	sta	bp|A
	stq	bp|C
	ldq	bp|q
	mpy	bp|D
	negl	0
	adl	bp|B
	lda	bp|D
	sta	bp|B
	stq	bp|D
	ldq	bp|q
	mpy	bp|vh
	negl	0
	adl	bp|uh
	lda	bp|vh
	sta	bp|uh
	stq	bp|vh
	tra	gcd_bb_l2
gcd_bb_l4:
	szn	bp|B
	tze	gcd_bb_doremain
	epplp	bp|up,*			"calc Au, Bv, Cu, and Dv, then combine
	sprilp	bp|biggerp
	lxl6	lp|0
	eax6	1,x6
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	sprilp	bp|ptemp1
	eax2	0
	lda	bp|A
	tpl	3,ic			"set sign of result
	neg	0
	eax2	-1
	stx2	lp|0
	sta	bp|multiplier
	tsx0	mpy_bs
	epplp	bp|vp,*
	sprilp	bp|biggerp
	lxl6	lp|0
	eax6	1,x6
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	sprilp	bp|ptemp2
	eax2	0
	lda	bp|B
	tpl	3,ic
	neg	0
	eax2	-1
	stx2	lp|0
	sta	bp|multiplier
	tsx0	mpy_bs
	epplp	bp|up,*
	sprilp	bp|biggerp
	lxl6	lp|0
	eax6	1,x6
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	sprilp	bp|ptemp3
	eax2	0
	lda	bp|C
	tpl	3,ic
	neg	0
	eax2	-1
	stx2	lp|0
	sta	bp|multiplier
	tsx0	mpy_bs
	epplp	bp|vp,*
	sprilp	bp|biggerp
	lxl6	lp|0
	eax6	1,x6
	tsx0	alloc_bfx6
	sprilp	bp|resultp
	sprilp	bp|ptemp4
	eax2	0
	lda	bp|D
	tpl	3,ic
	neg	0
	eax2	-1
	stx2	lp|0
	sta	bp|multiplier
	tsx0	mpy_bs
	ldaq	bp|ptemp1			"do the combining
	staq	bp|biggerp
	ldaq	bp|ptemp2
	staq	bp|smallerp
	ldaq	bp|up
	staq	bp|resultp
	tsx0	add_bb
	tsx0	truncate_bfx
	nop	0,dl
	ldaq	bp|ptemp3
	staq	bp|biggerp
	ldaq	bp|ptemp4
	staq	bp|smallerp
	ldaq	bp|vp
	staq	bp|resultp
	tsx0	add_bb
	tsx0	truncate_bfx
	nop	0,dl
	ldx7	bp|initial_value		"release all scratch space used above
	tra	gcd_bb_l1			"go around again
gcd_bb_doremain:
	ldaq	bp|up
	staq	bp|biggerp
	ldaq	bp|vp
	staq	bp|smallerp		"do normal remainder way
	tsx0	div_bb
	epplp	bp|vp,*
	sprilp	bp|resultp
	epplp	bp|up,*
	tsx6	move_bfx			"move v to u
	ldx2	bp|n			"normalize remainder, and put in v
	epplp	bp|dividendp,*
	stz	lp|0			"make positive
	sxl2	lp|0			"store size
	sprilp	bp|resultp
	tsx0	rsh_bfx
	tsx0	truncate_bfx
	nop	0,dl
	epplp	bp|vp,*
	tsx6	move_bfx
	ldx7	bp|initial_value		"clean up mess
	tra	gcd_bb_l1
gcd_bb_to_bs:
	epplp	bp|vp,*			"set up for bs
	sprilp	bp|resultp
	tsx0	convert_bfx_to_sfx		"make the smaller one an sfx
	stq	bp|divisor
	epplp	bp|up,*
	tra	gcd_sb_join
"
"
haulong:	lcq	-fn_haulong,dl		" function to count significant bits in a number.
	eax5	-2
	tsx0	enter			" set up.
	tsx0	numval			" check argument type.
	tra	haulong_sfx
	tra	badarg
	tra	haulong_bfx
haulong_sfx:				" single precision haulong.
	lda	ap|1,x5			" load argument.
	tsx0	norm_a			" normalize it
	tra	return_sfx		" return Q, which contains number of significant bits.

haulong_bfx:
	epplp	ap|0,x5*			" get pointer to bignum
	lxl2	lp|0			" get number words in bignum
	lda	lp|0,x2			" load the most significant word.
	tsx0	norm_a			" get number of significant bits in Q.
	stq	bp|temp			" and remember for later.
	eaq	-1,x2			" get number of words in bignum in Q.
	qrs	18
	mpy	35,dl			" 35 bits per word.
	adq	bp|temp
	tra	return_sfx
	end
	fld	ap|-3			"get base
	tze	return_0.0		"0**x is zero, floating point
	fcmp	=1.0,du			"special case 1**x, -1**x
	tze	return_1.0
	fcmp	=-1.0,du
	tnz	expt_sfl_sfx_nmo
	lda	ap|-1
	cana	1,dl			"test power for odd/even
	tze	return_1.0
	fld	=-1.0,du
	tra	return_sfl
expt_sfl_sfx_nmo:




		    lisp_car_cdrs_.alm              07/06/83  0937.8r w 06/29/83  1542.7       32769



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
"	lisp_car_cdrs_	- contains all the car's and cdr's of lisp....
"
"
"  Modified 1982.10.06 by Richard Lamson to add nth and nthcdr
"


	include	lisp_object_types

	segdef	car
	segdef	quote
	segdef	cdr

"	The fast two...

quote:
car:	ldaq	ap|-2,*
	tra	zap_out-*,ic
cdr:	eax0	2		for post index
	ldaq	ap|-2,*0
zap_out:	eppap	ap|-2		pop stack back
	tra	bp|0		and return

"
"	Now the slightly slower ones, entered with a save lp...
"
	segdef	cddddr
	segdef	cadddr
	segdef	cdaddr
	segdef	caaddr
	segdef	cddadr
	segdef	cadadr
	segdef	cdaadr
	segdef	caaadr
	segdef	cdddar
	segdef	caddar
	segdef	cdadar
	segdef	caadar
	segdef	cddaar
	segdef	cadaar
	segdef	cdaaar
	segdef	caaaar

	segdef	cdddr
	segdef	caddr
	segdef	cdadr
	segdef	caadr
	segdef	cddar
	segdef	cadar
	segdef	cdaar
	segdef	caaar

	segdef	cddr
	segdef	cadr
	segdef	cdar
	segdef	caar

cddddr:	eppbp	ap|-2,*
	eppbp	bp|2,*
cddd:	eppbp	bp|2,*
cdd:	eppbp	bp|2,*
cd:	ldaq	bp|2
c:	eppap	ap|-2
	epplp	ab|-4,7*
	eppbp	ab|-2,7*
	eax7	-4,7
	tra	bp|0

cadddr:	eppbp	ap|-2,*
	eppbp	bp|2,*
cadd:	eppbp	bp|2,*
cad:	ldaq	bp|2,*
	tra	c-*,ic
cdaddr:	eppbp	ap|-2,*
	eppbp	bp|2,*
cdad:	eppbp	bp|2,*
cda:	eppbp	bp|0,*
	tra	cd-*,ic
caaddr:	eppbp	ap|-2,*
	eppbp	bp|2,*
caad:	eppbp	bp|2,*
caa:	ldaq	bp|0,*
	tra	c-*,ic
cddadr:	eppbp	ap|-2,*
	eppbp	bp|2,*
cdda:	eppbp	bp|0,*
	tra	cdd-*,ic
cadadr:	eppbp	ap|-2,*
	eppbp	bp|2,*
cada:	eppbp	bp|0,*
	tra	cad-*,ic
cdaadr:	eppbp	ap|-2,*
	eppbp	bp|2,*
cdaa:	eppbp	bp|0,*
	tra	cda-*,ic
caaadr:	eppbp	ap|-2,*
	eppbp	bp|2,*
caaa:	eppbp	bp|0,*
	tra	caa-*,ic
cdddar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	cddd-*,ic
caddar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	cadd-*,ic
cdadar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	cdad-*,ic
caadar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	caad-*,ic
cddaar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	cdda-*,ic
cadaar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	cada-*,ic
cdaaar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	cdaa-*,ic
caaaar:	eppbp	ap|-2,*
	eppbp	bp|0,*
	tra	caaa-*,ic

cdddr:	eppbp	ap|-2,*
	tra	cddd-*,ic
caddr:	eppbp	ap|-2,*
	tra	cadd-*,ic
cdadr:	eppbp	ap|-2,*
	tra	cdad-*,ic
caadr:	eppbp	ap|-2,*
	tra	caad-*,ic
cddar:	eppbp	ap|-2,*
	tra	cdda-*,ic
cadar:	eppbp	ap|-2,*
	tra	cada-*,ic
cdaar:	eppbp	ap|-2,*
	tra	cdaa-*,ic
caaar:	eppbp	ap|-2,*
	tra	caaa-*,ic

cddr:	eppbp	ap|-2,*
	tra	cdd-*,ic
cadr:	eppbp	ap|-2,*
	tra	cad-*,ic
cdar:	eppbp	ap|-2,*
	tra	cda-*,ic
caar:	eppbp	ap|-2,*
	tra	caa-*,ic

" nth:  (nth n list): returns (ca(d**n)r list)
	segdef	nth
nth:	lxl0	ap|-3	get n in x0
	eppbp	ap|-2,*	and the list in bp
nthloop:	eax0	-1,x0	count
	tmi	nthreturns-*,ic
	eppbp	bp|2,*	cdr
	tra	nthloop-*,ic
nthreturns:
	ldaq	bp|0	return car
	eppap	ap|-4     pop our args.
	tra	c+1-*,ic

" nthcdr: (nthcdr n list) returns (c(d**n)r list)
	segdef	nthcdr
nthcdr:	lxl0	ap|-3	get n in x0
	eax7	2,x7
	sprilp	ab|-2,x7
	epplp	ap|-2	get address first cons in lp
	eppbp	lp|0,*	and the cons in bp
	lda	Atomic,dl
nthcdrloop:
	cana	lp|0	test to see if end of list
	tnz	nthcdrreturnsnil-*,ic
	eax0	-1,x0	count
	tmi	nthcdrreturns-*,ic
	epplp	bp|2	pointer to next cons
	eppbp	lp|0,*	cdr
	tra	nthcdrloop-*,ic
nthcdrreturns:
	epplp	ab|-2,x7*
	eax7	-2,x7
	spribp	ap|-4	we need to return this cdr
	ldaq	ap|-4	get it into AQ
	eppap	ap|-4	pop our args
	tra	c+1-*,ic	return
nthcdrreturnsnil:
	epplp	ab|-2,x7*
	eax7	-2,x7
	ldaq	lisp_static_vars_$nil
	eppap	ap|-4
	tra	c+1-*,ic


	end




		    lisp_error_table_.alm           07/06/83  0937.8r w 06/29/83  1542.7      100953



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
"	lisp_error_table_: October 1982 by Richard Lamson
"
" This version written in October 1982, with messages cribbed from 
" lisp_error_table_.macro.  Converted from macro form to alm by
" Richard Lamson
"

	bool	data,400000
	bool	print,200000
	bool	listify,100000
	bool	special_begin,040000
	bool	user_interrupt_present,020000
	bool	eval,010000
	bool	special_interrupt,004000
	bool	special_finish,002000
	bool	status_code,001000
	bool	has_fault_save_frame,000400
	bool	sptrapf,000200		" Not used in this program.
	bool	function_name,000100

	use	Messages
	segdef	msgs
msgs:
	use	Interrupt_numbers
	segdef	uintnum:
uintnum:
	use	Attributes
	segdef	bit_tbl
bit_tbl:

	set	NEXT_ERROR_CODE,100

	macro	error_code
	use	Codes
	segdef	&1
&1:	vfd	36/NEXT_ERROR_CODE
	set	NEXT_ERROR_CODE,NEXT_ERROR_CODE+1
	use	Messages
	aci	"&2",40
	use	Interrupt_numbers
&=&4.,.&[	dec	0
&;	dec	&4
&]
	use	Attributes
&=&4.,.&[	vfd	18/&3
&;	vfd	18/&3+user_interrupt_present
&]
	&end


error_code undefined_atom,(undefined atomic symbol),listify+data+print+eval,6
error_code undefined_function,(undefined function),listify+data+print,5
error_code too_many_args,(lisp: ^a called with too many arguments`),function_name+eval,9
error_code too_few_args,(lisp: ^a called with too few arguments`),function_name+eval,9
error_code file_system_error,([Obsolete Error]),status_code
error_code bad_argument,(lisp: function ^a rejected argument `),function_name+print+data
error_code undefined_subr,(attempt to link to subr failed!),()
error_code bad_function,(invalid functional form),print+data
error_code bad_bv,(attempt to bind non-variable),print+data
error_code unseen_go_tag,(go to an undefined tag),listify+print+data,8
error_code throw_to_no_catch,(throw can't find a catch),listify+print+data,8
error_code non_fixed_arg,(lisp: argument must be fixnum - ^a on `),function_name+print+listify+data,7
error_code parenmissing,(parenthesis missing - read),()
error_code doterror,(dot context error - read),()
error_code illobj,(unreckognizable object - read),()
error_code badmacro,(read macro character lost:),print+data
error_code shortreadlist,(list too short - readlist),()
error_code badreadlist,(invalid character object),print+data
error_code array_bound_error,([Obsolete Error]),has_fault_save_frame+print+data,11
error_code car_cdr_error,(car or cdr of number),has_fault_save_frame
error_code bad_arg_correctable,(lisp: function ^a rejected argument `),listify+print+data+function_name,7
error_code bad_prog_op,(no prog - go or return),special_interrupt+special_finish,11
error_code no_lexpr,(no lexpr - arg or setarg),print+data+special_finish,11
error_code wrong_no_args,(wrong number of arguments - eval),print+data+eval,9
error_code bad_ibase,(improper ibase, changed to 8),listify+special_begin+special_interrupt+special_finish,11
error_code bad_base,(improper base, changed to 8),listify+special_begin+special_interrupt+special_finish,11
error_code bad_input_source,(bad input source),print+data,7
error_code bad_output_dest,(bad output destination),print+data,7
error_code nihil_ex_nihile,(nihil ex nihil - don't setq or bind nil),special_interrupt+special_finish,11
error_code obsolete_131,([Obsolete Error]),()
error_code obsolete_132,([Obsolete Error]),()
error_code not_pdl_ptr,(lisp: ^a wanted a pdl pointer, but got `),function_name+listify+print+data,7
error_code obsolete_134,([Obsolete Error]),()
error_code obsolete_135,([Obsolete Error]),()
error_code bad_f_fcn,(call to unexpected fsubr or fexpr),print+data
error_code overflow_err,(lisp: overflow while ^a was acting on `),function_name+print+data
error_code mismatch_super_parens,(mismatched super-parentheses:),print+data
error_code no_left_super_paren,(missing left super-parenthesis),()
error_code flonum_too_big,(flonum out of range - read),()
error_code quoterror,(illegal format - ' macro),()
error_code badreadtable,(bad readtable),()
error_code badobarray,(bad obarray),()
error_code atan_0_0_err,(atan 0 0 is not allowed),()
error_code unable_to_float,(this bignum is too big to be floated:),listify+print+data+eval,7
error_code division_by_zero,(division by zero),()
error_code eof_in_object,(end of file in the middle of an object),listify+special_interrupt,11
error_code cant_filepos,(filepos doesn't work on streams),print+data+eval,11
error_code filepos_oob,(attempt to filepos past end of file),print+data+eval,11
error_code file_sys_fun_err,(),status_code+print+data+eval,11
error_code stars_left_in_name,(imprecise namelist),print+data+eval,11
error_code io_wrong_direction,(not opended for I/O in this direction),print+data,11
error_code file_is_closed,(a closed file cannot do I/O),print+data,11
error_code reopen_inconsistent,(unable to re-open saved file),print+data,11
error_code bad_entry_name,(entryname too long or missing),print+data+eval,7
error_code bad_do_format,(improper format - do),print+data
error_code not_an_array,(lisp: ^a rejected non-array argument `),function_name+print+data+eval,7
error_code not_alpha_array,(lisp: ^a found non-alpha elements of `),function_name+print+data+eval,7
error_code include_file_error,(),status_code+print+data
error_code stack_loss_error,(pdl overflow - infinite recursion?),has_fault_save_frame+data+special_finish,12 
error_code underflow_fault,(arithmetic underflow),has_fault_save_frame+data,11
error_code zerodivide_fault,(attempt to divide by zero),has_fault_save_frame+data,11
error_code bad_array_subscript,(bad array subscript),print+data
error_code store_not_allowed,(lisp: can't store into this array - ^a `),function_name+print+data
error_code dead_array_reference,(attempt to reference a dead array),print+data
error_code cant_subscript_readtable,(subscripted reference to a readtable),print+data
error_code not_same_type,(lisp: arrays not of same type - ^a `),function_name+print+data
error_code special_array_type,(lisp: illegal type of array for ^a `),function_name+print+data
error_code array_too_big,(attempt to create an overly-large array),print+data
error_code argument_must_be_array,(lisp: ^a wants an array, not `),function_name+print+data
error_code store_function_misused,(the 'store' function was misused),has_fault_save_frame
error_code meaningless_argument_number,(lisp: meaningless argument number - ^a `),data+print+listify+function_name,7
error_code subrcall_bad_ptr,(not a subr pointer - subrcall),print+data
error_code lsubrcall_bad_ptr,(not an lsubr pointer - lsubrcall),print+data
error_code arraycall_bad_ptr,(not an array pointer - arraycall),print+data
error_code arraycall_wrong_type,(array not of specified type - arraycall),print+data
error_code csd_op_barf,(illegal string argument to a defpl1 subr),()
error_code cad_op_barf,(improper array argument to a defpl1 subr),()
error_code wrong_external_array_ndims,(an external array must have 1 dimension),print+data
error_code cant_set_plist,(illegal attempt to setplist),listify+print+data,7
error_code bad_item_in_modelist,(unrecognized item in modelist),listify+print+data,7

	use	Codes
	segdef	hbound
hbound:	vfd	36/NEXT_ERROR_CODE-1

	macro	function_name
	aci	"&1",16
	&end

	segdef	fnames
fnames:
function_name	do
function_name	arg
function_name	setarg
function_name	status
function_name	sstatus
function_name	errprint
function_name	errframe
function_name	evalframe
function_name	defaultf
function_name	??unused19??
function_name	??unused20??
function_name	crunit
function_name	tyo
function_name	ascii
function_name	rplaca
function_name	definedp
function_name	setq
function_name	set
function_name	delete
function_name	delq
function_name	stringlength
function_name	catenate
function_name	array
function_name	substr
function_name	index
function_name	get_pname
function_name	make_atom
function_name	ItoC
function_name	CtoI
function_name	defsubr
function_name	*array
function_name	args
function_name	sysp
function_name	get
function_name	getl
function_name	putprop
function_name	remprop
function_name	save
function_name	add1
function_name	sub1
function_name	greaterp
function_name	lessp
function_name	minus
function_name	plus
function_name	times
function_name	difference
function_name	quotient
function_name	abs
function_name	expt
function_name	boole
function_name	rot
function_name	lsh
function_name	signp
function_name	fix
function_name	float
function_name	remainder
function_name	max
function_name	min
function_name	1+
function_name	1+$
function_name	1-
function_name	1-$
function_name	+
function_name	+$
function_name	*
function_name	*$
function_name	-
function_name	-$
function_name	/
function_name	/$
function_name	eval
function_name	apply
function_name	prog
function_name	errset
function_name	catch
function_name	throw
function_name	store
function_name	defun
function_name	baktrace
function_name	bltarray
function_name	*rearray
function_name	gensym
function_name	makunbound
function_name	boundp
function_name	*status
function_name	*sstatus
function_name	freturn
function_name	cos
function_name	sin
function_name	exp
function_name	log
function_name	sqrt
function_name	isqrt
function_name	atan
function_name	sleep
function_name	oddp
function_name	tyipeek
function_name	alarmclock
function_name	plusp
function_name	minusp
function_name	<
function_name	=
function_name	>
function_name	alphalessp
function_name	samepnamep
function_name	getchar
function_name	opena
function_name	sxhash
function_name	gcd
function_name	allfiles
function_name	chrct
function_name	close
function_name	deletef
function_name	eoffn
function_name	filepos
function_name	inpush
function_name	linel
function_name	mergef
function_name	namelist
function_name	names
function_name	namestring
function_name	openi
function_name	openo
function_name	prin1
function_name	princ
function_name	print
function_name	read
function_name	readch
function_name	readline
function_name	rename
function_name	shortnamestring
function_name	tyi
function_name	setsyntax
function_name	cursorpos
function_name	force-output
function_name	clear-input
function_name	random
function_name	haulong
function_name	haipart
function_name	cline
function_name	fillarray
function_name	listarray
function_name	sort
function_name	sortcar
function_name	zerop
function_name	listify
function_name	charpos
function_name	pagel
function_name	linenum
function_name	pagenum
function_name	endpagefn
function_name	arraydims
function_name	loadarrays
function_name	dumparrays
function_name	^
function_name	^$
function_name	nointerrupt
function_name	open
function_name	in
function_name	out
function_name	truename
function_name	ifix
function_name	fsc
function_name	progv
function_name	mapatoms
function_name	unwind-protect
function_name	eval-when
function_name	read-from-string
function_name	displace
function_name	nth
function_name	nthcdr
function_name	includef
function_name	?


	segdef	fnames_hbound
fnames_hbound:
	vfd	36/(*-fnames)/4+9   " The nine is a fudge factor,
				" because fn_do starts at -10

	join	/text/Codes,Messages,Interrupt_numbers,Attributes
	end




		    lisp_flonum_conversion_.alm     07/06/83  0937.8r w 06/29/83  1542.7       64926



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1974 *
" *                                                            *
" **************************************************************
   	name lisp_flonum_conversion_

" This routine converts flonums to character string s for the benefit of lisp_print_
" It can probably be replaced by numeric_to_ascii_ when that routine is installed.
" Written 74.03.18 by DAM

" This routine is called with one argument, as follows
"    1 argument_structure aligned,
"      2 flonum float bin(27)		number to be converted
"      2 bufp pointer unaligned	-> char(76) varying string
"      2 temps_for_this_routine,
"         	3 mantissa fixed bin(27)
"	3 exponent fixed bin(8)
"	3 dec_temp float decimal(10)
"	3 dec_exp float decimal(10)
"	3 dbl_temp fixed bin(71)

	equ	flonum,0
	equ	bufp,1
	equ	mantissa,2
	equ	exponent,3
	equ	dec_temp,4
	equ	dec_exp,7
	equ	dbl_temp,10

	equ	varying_string_length,0
	equ	varying_string_chars,1


zero_table:	" TCT table for looking for zeroes

	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	9/0,27/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1
	vfd	36/-1

minus_sign: aci	/-/

zero_point_zero:
	aci	/0.0/

a_zero:	aci	/0/

a_dot:	aci	/./

e_plus_e_minus:  aci  /e+e-/

two_to_the_64:
	aci	/18446744073709551616/	20. characters

	segdef	lisp_flonum_conversion_

lisp_flonum_conversion_:

	eppap	ap|2,*		-> argument structure
	fld	ap|flonum		pick up argument
	tze	special_case_zero	only needed because of bug in MVN instruction
	ars	8		explode the flonum
	sta	ap|mantissa
	ste	ap|exponent
	btd	(pr),(pr)		convert mantissa to decimal
	desc9a	ap|mantissa,4
	desc9ls	ap|dec_temp,11
	mvn	(pr),(pr)		better float it right away
	desc9ls	ap|dec_temp,11
	desc9fl	ap|dec_temp,12
	lda	ap|exponent
	ars	36-8
	sba	27,dl
	sta	ap|exponent		save sign
	tpl	2,ic
	neg	0
g0001:	cmpa	64,dl			too big to shift?
	tmi	g0002			no, go ahead
	sba	64,dl			yes, do 64 powers sperately
	szn	ap|exponent
	tmi	g0003
	mp2d	(),(pr),round
	desc9ns	two_to_the_64,20,0
	desc9fl	ap|dec_temp,12
	tra	g0001

g0003:	dv2d	(),(pr),round
	desc9ns	two_to_the_64,20,0
	desc9fl	ap|dec_temp,12
	tra	g0001

g0002:	eax1	0,al
	lda	0,dl
	ldq	1,dl
	lls	0,x1
	staq	ap|dbl_temp
	btd	(pr),(pr)
	desc9a	ap|dbl_temp,8
	desc4ns	ap|dec_exp,40	clobber 5 words, 3 of which are dec_exp, 2 dbl_temp
	mvn	(pr),(pr),round
	desc4ns	ap|dec_exp,40
	desc9fl	ap|dec_exp,12
	szn	ap|exponent
	tmi	neg_exponent
pos_exponent:
	mp2d	(pr),(pr),round
	desc9fl	ap|dec_exp,12
	desc9fl	ap|dec_temp,12
	tra	got_dec_num

neg_exponent:
	dv2d	(pr),(pr),round
	desc9fl	ap|dec_exp,12
	desc9fl	ap|dec_temp,12

got_dec_num:

""" Now round to 8 digits and decide whether it needs E format or will fit in F format

	mvn	(pr),(pr),round
	desc9fl	ap|dec_temp,12
	desc9fl	ap|dec_temp,10

	" scan out leading zeroes, if any

	tct	(pr),()
	desc9a	ap|dec_temp(1),8
	arg	zero_table
	arg	ap|dbl_temp
	lda	ap|dbl_temp
	ana	-1,dl
	ttf	2,ic
	lda	7,dl			if all zero, only flush first 7 zeroes
	sta	ap|dbl_temp

	ldq	8,dl
	sbq	ap|dbl_temp
	mlr	(pr,al,rl),(pr),fill(060)
	desc9a	ap|dec_temp(1),ql
	desc9a	ap|dec_temp(1),8

	lprpbp	ap|bufp			set up to emit stuff
	eax7	0			offset in varying string of next char

	szn	ap|mantissa
	tpl	it_is_positive
	mlr	(),(pr,x7)		put out minus sign
	desc9a	minus_sign,1
	desc9a	bp|varying_string_chars,1
	eax7	1,x7
it_is_positive:

	lda	ap|dec_temp+2		get decimal exponent
	als	10
	ars	36-8
	cmpa	=-8
	tmi	small_exponent

	cmpa	ap|dbl_temp			exponent too large?
	tpnz	E_format

F_format:	ada	ap|dbl_temp		- number of digits to right of decimal point
	sta	ap|exponent
	lda	8,dl			get number digits to left of point
	ada	ap|exponent
	tze	f3
	mlr	(pr,rl),(pr,x7,rl)
	desc9a	ap|dec_temp(1),al
	desc9a	bp|varying_string_chars,al
	eaa	0,al			:= adx7 a
	sta	ap|dbl_temp
	adx7	ap|dbl_temp
	tra	f2

f3:	mlr	(),(pr,x7)		no digits to left, supply a zero
	desc9a	a_zero,1
	desc9a	bp|varying_string_chars,1
	eax7	1,x7

f2:	mlr	(),(pr,x7)
	desc9a	a_dot,1			put decimal point
	desc9a	bp|varying_string_chars,1
	eax7	1,x7

	lca	ap|exponent		digits to right of point
	tze	f4			none, supply a zero.
	eax1	0,al
	lda	8,dl
	ada	ap|exponent		number digits need to be skipped.
	tctr	(pr,al,rl),()		truncate trailing zeroes
	desc9a	ap|dec_temp(1),x1
	arg	zero_table
	arg	ap|dbl_temp
	lxl2	ap|dbl_temp
	ttf	2,ic
	eax2	-1,x1			leave at least one zero
	stx2	ap|dbl_temp			x2 = number tr z's to suppress
	sbx1	ap|dbl_temp
	mlr	(pr,al,rl),(pr,x7,rl)
	desc9a	ap|dec_temp(1),x1
	desc9a	bp|varying_string_chars,x1
	stx1	ap|dbl_temp
	adx7	ap|dbl_temp		= adx7 x1
	tra	f5

f4:	mlr	(),(pr,x7)
	desc9a	a_zero,1
	desc9a	bp|varying_string_chars,1
	eax7	1,x7

f5:
done_update_string_length:
	stz	bp|varying_string_length
	sxl7	bp|varying_string_length
	short_return

small_exponent:	" probably has to go in E format, but could use F format if trailing zeroes

	tctr	(pr),()
	desc9a	ap|dec_temp(2),7
	arg	zero_table
	arg	ap|dbl_temp+1
	sta	ap|exponent		present exponent
	ada	8,dl			- number of leading zroes must have
	eax2	0
	stx2	ap|dbl_temp+1		:= number leading zeroes can get
	asa	ap|dbl_temp+1		set indicators from sum then throw away.
	tmi	E_format_after_all		need more than can have

" we can use F format just by putting in some leading zeroes instead of trailing zeroes

	eax2	8,al			:= number of non-lz characters
	mrl	(pr,rl),(pr),fill(060)	insert leading zeroes
	desc9a	ap|dec_temp(1),x2
	desc9a	ap|dec_temp(1),8
	neg	0
	ada	ap|exponent		offset exponent by amount of shift
	tra	F_format

E_format_after_all:
	lda	ap|exponent

E_format:
" a contains decimal exponent.  ap|dbl_temp contains count of leading zeroes
	sba	ap|dbl_temp		correct decimal exponent from lz suppr
	ada	7,dl			allow for decimal point being after first digit.
" a now has the exponent we want to print after the number
	sta	ap|exponent

	tctr	(pr),()
	desc9a	ap|dec_temp(1),8
	arg	zero_table
	arg	ap|dbl_temp
	lda	ap|dbl_temp
	ana	-1,dl
	ttf	2,ic
	lda	7,dl			if all zero, only use 7 zeroes.

	mlr	(pr),(pr,x7),fill(056)	move first digit and decimal point out
	desc9a	ap|dec_temp(1),1
	desc9a	bp|varying_string_chars,2
	eax7	2,x7

	neg	0			put number of trailing non-zeroes in au
	eaa	7,al
	tze	e2
	mlr	(pr,rl),(pr,x7,rl)
	desc9a	ap|dec_temp(2),au
	desc9a	bp|varying_string_chars,au
	sta	ap|dbl_temp
	adx7	ap|dbl_temp
	tra	e3

e2:	mlr	(),(pr,x7)
	desc9a	a_zero,1
	desc9a	bp|varying_string_chars,1
	eax7	1,x7

e3:

""" Now put out the exponent.

	eax2	0
	szn	ap|exponent
	tpl	2,ic
	eax2	2
	mlr	(x2),(pr,x7)
	desc9a	e_plus_e_minus,2
	desc9a	bp|varying_string_chars,2
	eax7	2,x7

	btd	(pr),(pr,x7)
	desc9a	ap|exponent,4
	desc9ns	bp|varying_string_chars,2	2 digits of exponent.
	eax7	2,x7
	tra	done_update_string_length



special_case_zero:
	lprpbp	ap|bufp
	mlr	(),(pr)
	desc9a	zero_point_zero,3
	desc9a	bp|varying_string_chars,3
	ldq	3,dl
	stq	bp|varying_string_length
	short_return

	end




		    lisp_gc_alm_.alm                07/06/83  0937.8r w 06/29/83  1542.7      153720



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
" lisp_gc_alm_: ALM portion of lisp garbage collector
" Its history is unknown by the current maintainers.
"

	tempd	args(2)
	tempd	save_pr2
	tempd	array_data_ptr_ptr
	tempd	new_seg_ptr
	tempd	vector_ret
	tempd	cur_atom
	tempd 	cur_bucket_cell
	tempd	old_nil
	temp	vector_left
	temp	cur_vec_entry
	temp	dope_vec_size
	temp	mark_size
	temp	copy_size
	temp	vector_thread
	temp	gctwa_flag
	temp	gctwa_thread
	temp	gctwa_final
	include	lisp_iochan
	include	lisp_object_types
	even
noargs:	zero	0,4
	zero	0,0
onearg:	zero	2,4
	zero	0,0
nullptr:	its	-1,1

	entry	collect
collect:	push
	lda	pr0|2,*		" test for gctwa mode.
	sta	gctwa_flag
	ldaq	<lisp_static_vars_>|[nil]
	staq	old_nil			" copy for later use
	epp5	<lisp_alloc_>|[cur_seg],*
	spri5	pr0|4,*		" return value is list of old segment.
	epp5	nullptr,*
	tsx5	get_initial_segment	" this entry skips
	nop
	epp7	=0
	sprp7	vector_thread
	sprp7	gctwa_thread
	sprp7	gctwa_final

	lda	<lisp_static_vars_>|[number_gc_ptrs]
	neg	0
	sta	vector_left
	epp1	<lisp_static_vars_>|[garbage_collected_ptrs]
	stcd	vector_ret
	tra	vector_loop

	epp1	<lisp_static_vars_>|[stack_ptr],*
	eaa	pr1|0
	arl	18+1		"divide by 2
	neg	0
	sta	vector_left
	epbp1	pr1|0		" start at base of stack
	stcd	vector_ret
	tra	vector_loop

handle_vectors_encountered:		" this is now in vector_ret.
	lprp0	vector_thread
	szn	pr0|0	" end of vector thread is a zero word.
	tze	gctwa_phs1
	lda	pr0|1
	neg
	sta	vector_left
	lda	pr0|2
	sta	vector_thread
	lprp1	pr0|0
"	stcd	vector_ret
"	tra	vector_loop
"	tra	handle_vectors_encountered
vector_loop:
	sprp1	cur_vec_entry	"pr1 points to current slot in vector to ahndle.
	tsx4	copylist
	lprp1	cur_vec_entry
	epp1	pr1|2		" move to next entry
	aos	vector_left
	tmi	vector_loop
	rtcd	vector_ret

gctwa_phs1:			" see if anything is on gctwa thread,
				" process first element, then go back to
				" handle any vectors encountered.
				" this phase just collects all worthy atoms --
				" those that have a value or non-nil plist.
	lprp1	gctwa_thread
	szn	pr1|0		" test for empty thread
	tze	gctwa_phs2	" if no elements on list, handle rest of gctwa.
	lprp0	pr1|0		" get pointer to obarray.
	lda	pr1|1		" and number of elements in it (buckets)
	neg
	sta	vector_left
	ldq	pr1|2		" move down gctwa_thread
	stq	gctwa_thread

	ldq	gctwa_final	" thread block onto phase 2 thread
	stq	pr1|2
	sprp1	gctwa_final

ph1_vec_loop:			" loop over all buckets.
	sprp0	cur_vec_entry
	epp1	pr0|0,*		" get first bucket ptr.
ph1_lst_loop:				" loop over list, until a cell already seen is encountered.
	ldaq	pr1|0		" get car of first cell.
	tmi	ph1_next_bucket
	staq	cur_atom		" if not marked, must be atom (maybe worthwhile)
	ldaq	pr1|2		" get ptr to next cell
	staq	cur_bucket_cell
	epp0	cur_atom,*		" get ptr to atom
	ldaq	pr0|0		" and test its car.
	tmi	ph1_next_atom	" already seen and marked,
	tpnz	worthy_atom	" this is a worthy atom because it has a value.
	ldaq	pr0|2		" load plist ptr
	cmpaq	old_nil	" nil should have been collected already!
	tze	ph1_next_atom
worthy_atom:
	epp1	cur_atom		" collect the atom. We know it has not already been seen.
	tsx4	cplistlp		" SO, we call past the already_seen check.
ph1_next_atom:
	epp1	cur_bucket_cell,*	" get ptr to next bucket cell.
	tra	ph1_lst_loop
ph1_next_bucket:
	lprp0	cur_vec_entry
	epp0	pr0|2			" move to next bucket
	aos	vector_left
	tmi	ph1_vec_loop

	tra	handle_vectors_encountered	" may have found new vectors or obarrays to collect.

gctwa_phs2:
	lprp1	gctwa_final
	szn	pr1|0
	tze	scan_maknum
	lprp0	pr1|0		" get next element.
	lda	pr1|1
	neg
	sta	vector_left
	ldq	pr1|2
	stq	gctwa_final		" thread off list.

ph2_vec_loop:
	epp3	pr0|0			" keep ptr to place to patch in next bucket cell
	epp1	pr0|0,*			" get ptr to first cell in bucket.
ph2_lst_loop:
	ldaq	pr1|0			" check for end (a marked cell)
	tmi	ph2_end_list
	ldaq	pr1|0,*			" load car of atom to test if marked.
	tpl	ph2_worthless		" if not seen yet, worthless.
	era	=o400000,du		" clear mark bit, to get new location
ph2_make_cell:
	epp2	pr5|2,ad		" allocate a cons cell to append to bucket
	ttf	ph2_made_cell
	tsx5	tally_ran_out		" handle tally runout
	tra	ph2_made_cell
	tra	ph2_make_cell
ph2_made_cell:
	staq	pr2|0		" store worthy atom in car of cell
	spri2	pr3|0		" patch new cell in at end of list
	epp3	pr2|2		" and new place to patch is cdr of new cell.
ph2_worthless:
	epp1	pr1|2,*		" get ptr to next cell
	tra	ph2_lst_loop
ph2_end_list:
	era	=o400000,du	" turn off mark bit to get ptr to tail of bucket list
	staq	pr3|0		" patch it into end of new list.
	epp0	pr0|2		" move to next bucket
	aos	vector_left
	tmi	ph2_vec_loop

	tra	gctwa_phs2	" and go handle next obarray


scan_maknum:
	epp1	<lisp_static_vars_>|[maknum_table_ptr],*
	ldq	<lisp_static_vars_>|[maknum_mask]
	adq	1,dl
	tze	retrn
	stz	<lisp_static_vars_>|[maknum_left]
	lls	36	divide by 8 and shift to negate
	arl	3
	neg
	sta	vector_left	" number of entries in maknum hash table.

maknum_scan_loop:
	ldq	pr1|0		" type is in low-order 9 bits.
	tze	next_entry
	canq	(Fixed+Float)/64,dl	
	tnz	ok_entry
	lprp0	pr1|1
	canq	(Subr+File)/64,dl	" check for subrs arrays and files.
	tnz	ck_saf_maknum_entry
	ldaq	pr0|0		" load word with mark bit.
	tpl	not_ok_entry		" entry not otherwise protected.
	cana	=o200000,du		" for bignums, have to check second bit,
	tnz	not_ok_entry		" which should be off for ptrs, but may be on in negative bignums.
	era	=o400000,du		" turn off mark bit.
	sta	pr1|1		" store new address (segno part)
	qrl	18
	stbq	pr1|1,14		" and word part in lower two bytes.
ok_entry:aos	<lisp_static_vars_>|[maknum_left]
	tra	next_entry
ck_saf_maknum_entry:
	canq	File/64,dl
	tnz	file_maknum_entry
	canq	Array/64,dl
	tnz	array_maknum_entry
	lxl0	pr0|1			" check array type.
	cmpx0	=o700004,du		" should be tsx0 ,ic if compiled subr.
	tnz	ok_entry		" if not compiled, ok to keep in maknum table
	ldx0	pr0|1			" otherwise check to see if already seen
	epp0	pr0|-2,x0		" get subr header
	ldx0	pr0|7			" get gc_mark halfword
test_maknum_gc_mark:
	canx0	<lisp_static_vars_>|[gc_mark_bits]
	tnz	ok_entry
	tra	not_ok_entry
array_maknum_entry:
	lxl0	pr0|0			" load gc_mark_ bits
	tra	test_maknum_gc_mark
file_maknum_entry:
	ldx0	pr0|iochan.flags
	canx0	iochan.gc_mark,du
	tnz	ok_entry
	tra	not_ok_entry

not_ok_entry:
	stz	pr1|0		" clear type and uid word of maknum table entry
next_entry:
	epp1	pr1|2
	aos	vector_left
	tmi	maknum_scan_loop

done_maknum_scan:
	lda	=o400000,du
	sta	<lisp_static_vars_>|[garbage_collect_inhibit]
	epp0	noargs
	epbp7	pr6|0			" find stack base.
	short_call <lisp_alloc_>|[rehash_maknum]
	stz	<lisp_static_vars_>|[garbage_collect_inhibit]

retrn:
	epbp7	pr6|0		" make return know where stack base is.
	return

already_seen:			" called with pr1 pointing at object.
				" call is tsx7.  routine returns to next
				" instruction, having patched doubleword
				" at pr1 if object has been moved already.
				" if an Atsym or Cons, and not yet moved,
				" then routine skips on return.

	ldaq	pr1|0		" load object to test for 0
	tze	0,x7		" (uninitialized atsym or stack entry)

	ana	=o060077,dl	" mask out modifier
				"exit on non-gc'able strings, too.
	cmpa	=o43,dl		" and check for its.
	tnz	0,x7		" must be number or error.

	lda	pr1|0		" load type field again.
	cana	Atomic-Atsym,dl	" see if atomic. (atsym is treated like cons)
	tnz	seen_atoms

test_cons:
	ldaq	pr1|0,*		" load car of cons.
	tpl	1,x7		" mark bit not set, so not seen yet.
unmark_return:
	era	=o400000,du		" clear mark bit.
	staq	pr1|0			" store new location in argument.
	tra	0,x7			" return as already seen.

seen_atoms:
	cana	Subr,dl
	tnz	test_subr

	cana	File,dl
	tnz	test_file

	cana	Bignum,dl
	tnz	test_bignum

	cana	String,dl
	tnz	test_string

	"ERROR IF GET HERE.
	tra	0,x7


test_string:
	ldaq	pr1|0,*
	tmi	unmark_return
	lrl	36
	adq	3,dl	" extra cells of 4 words (16 bytes to allocate)
	qrl	4
	tsx6	allocate_cells
	spri2	save_pr2
	epp2	pr1|0,*
	ldq	pr2|0		"get length.
	adq	4,dl
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr0|0,ql
	spri0	pr1|0	" now store new address back.
	ldaq	pr1|0	" and set type
	ora	String,dl
	staq	pr1|0
	ora	=o400000,du	" and set mark bit.
	staq	pr2|0
	epp2	save_pr2,*	" get back pr2
	tra	0,x7

test_bignum:
	" a bignum is marked by having the mark bit on, and the second
	" bit off (normally the two high-order bits are on or off together).
	ldaq	pr1|0,*		" load first double-word
	tpl	unseen_bignum
	cana	=o200000,du	" test second bit.
	tze	unmark_return
unseen_bignum:
	lrl	36
	anq	-1,dl	" mask out length.
	qrl	2	" divide by 4 (alloc multiple of 4)
	tsx6	allocate_cells
	spri2	save_pr2
	epp2	pr1|0,*
	ldq	pr2|0
	anq	-1,dl
	qls	2
	adq	4,dl
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr0|0,ql
	spri0	pr1|0
	ldaq	pr1|0
	ora	Bignum,dl
	staq	pr1|0
	ora	=o400000,du
	staq	pr2|0
	epp2	save_pr2,*
	tra	0,x7

test_file:
	epp0	pr1|0,*	get address of file block.
	lda	pr0|iochan.flags
	cana	iochan.gc_mark,du
	tnz	0,x7			" return if marked already.

	ora	iochan.gc_mark,du
	sta	pr0|iochan.flags

	epp0	pr0|iochan.function
	spri2	save_pr2
allocate_file_thread_block:
	epp2	pr5|2,ad
	ttf	file_thread_block_made
	tsx5	tally_ran_out
	tra	file_thread_block_made
	tra 	allocate_file_thread_block
file_thread_block_made:
	sprp0	pr2|0
	ldq	2,dl
	stq	pr2|1
	ldq	vector_thread
	stq	pr2|2
	sprp2	vector_thread
	epp2	save_pr2,*
	tra	0,x7

test_subr:
	epp0	pr1|0,*		" get what subr object points at.
	canq	1,du		" fix odd address, which arises in subr links to subrs and arrays.
	tze	2,ic
	epp0	pr0|-1

	cana	Array,dl		" screen out arrays.
	tnz	test_array

	lxl0	pr0|1	" load 2nd word of subr entry.
	cmpx0	=o700004,du	" tsx0 ..,ic
	tnz	0,x7		" if not this value, then nothing to do.

	ldx0	pr0|1		" to get to header.
	epp0	pr0|-1,x0

	ldx0	pr0|7		" gc mark.
	canx0	<lisp_static_vars_>|[gc_mark_bits]
	tnz	0,x7
	
"	THREAD SUBR ONTO VECTOR THREAD
"	AND MARK.

	ldx0	<lisp_static_vars_>|[gc_mark_bits]
	stx0	pr0|7
	spri2	save_pr2
retry_subr_block_thread:
	epp2	pr5|2,ad
	ttf	subr_thread_block_made
	tsx5	tally_ran_out
	tra	subr_thread_block_made
	tra 	retry_subr_block_thread
subr_thread_block_made:
	ldq	vector_thread
	stq	pr2|2
	lxl0	pr0|7
	sxl0	pr2|1
	epp0	pr0|8
	sprp0	pr2|0
	sprp2	vector_thread
	epp2	save_pr2,*
	tra	0,x7


test_array:
	lxl0	pr0|0	"gc mark.
	canx0	<lisp_static_vars_>|[gc_mark_bits]
	tnz	0,x7

" NOW COPY ARRAY BODY, PYT ARRAY ON LIST, AND MARK.

	ldx0	<lisp_static_vars_>|[gc_mark_bits]
	sxl0	pr0|0		"mark array.

	ldx0	pr0|7		" get type.
	tra	array_handlers,x0
array_handlers:
	tra	S_expr_array
	tra	Un_gc_array
	tra	number_array
	tra	number_array
	tra	readtable_array
	tra	obarray_array
	tra	0,x7		" dead array, nothing to do.

compute_size:
	lxl2	pr0|7	" offset to bounds array.
	eaa	0,x2		" get size of dope vector in words.
	neg
	arl	18
	sta	dope_vec_size
	spri2	save_pr2
	epp2	pr0|2	" get ptr to array_data_ptr
	spri2	array_data_ptr_ptr
	epp2	pr2|0,*
	ldq	1,dl
csizelp:	epp2	pr2|-2
	mpy	pr2|0
	eax2	2,x2
	tmi	csizelp
	tra	0,x6

number_array:
	lxl2	pr0|7		Check for external array
	tze	0,7		Leave alone if so.
	tsx6	compute_size
	adq	dope_vec_size
	stq	copy_size
	sbq	1,dl		" to get number of additional blocks to allocate.
	arl	2		" divide by 4.
	tsx6	allocate_cells
	ldq	copy_size
	qls	2	" 4 bytes per word.
	mlr 	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr0|0,ql
	ldq	dope_vec_size
	epp0	pr0|0,ql
	spri0	array_data_ptr_ptr,*
	epp2	save_pr2,*
	tra	0,x7


readtable_array:
	spri2	save_pr2
	epp2	pr0|2,*
	epp2	pr2|-2
	epp0	pr0|2
	spri0	array_data_ptr_ptr
	ldq	72,dl	" readtable size in 4 word blocks - 1
	tsx6	allocate_cells
	ldq	73*16,dl	" number of bytes to move.
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr0|0,ql
	epp0	pr0|2		" offset of data part
	spri0	array_data_ptr_ptr,*

	sprp0	pr2|0		" thread of gc'able vectors.
	ldq	9,dl		" number of markable-from words.
	stq	pr2|1
	ldq	vector_thread
	stq	pr2|2		" thread in to vector list
	sprp2	vector_thread

	epp2	save_pr2,*
	tra	0,x7

copy_array:			" called with tsx3.
	tsx6	compute_size
	stq	mark_size
	qls	1
	adq	dope_vec_size
	stq	copy_size
	sbq	1,dl
	qrl	2		" q now has 1 less than number of 4word blocks.
	tsx6	allocate_cells
	ldq	copy_size
	qls	2
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr0|0,ql
	ldq	dope_vec_size
	epp0	pr0|0,ql
	spri0	array_data_ptr_ptr,*
	tra	0,x3

obarray_array:
	szn	gctwa_flag
	tze	S_expr_array		" if not doing gctwa, treat as ordinary array

	tsx3	copy_array

	" now thread hash table part onto gctwa_thread, and single char atoms
	" on vector_thread

	sprp0	pr2|0
	ldq	511,dl
	stq	pr2|1
	ldq	gctwa_thread
	stq	pr2|2
	sprp2	gctwa_thread

	epp0	pr0|511*2
	epp2	pr2|3	" gctwa list cell uses 3 words, get vector list cell
	sprp0	pr2|0		" store ptr to singl char atom table.
	ldq	128,dl		" size of single char atom table
	stq	pr2|1
	ldq	vector_thread
	stq	pr2|2
	sprp2	vector_thread

	epp2	save_pr2,*
	tra	0,x7

Un_gc_array:
S_expr_array:
	tsx3	copy_array
	sprp0	pr2|0
	ldq	mark_size
	stq	pr2|1
	ldq	vector_thread
	stq	pr2|2
	sprp2	vector_thread

	epp2	save_pr2,*
	tra	0,x7


" copylist is called by a tsx4, with pr1 pointing at a double-word containing
" some lisp object.
" copylist implements a modified version of Douglas Clark's linearizing
" garbage collection algorithm.
" Atomic symbols are treated as list cells for this algorithm.
" Other types, such as arrays, files, subr blocks, etc. are copied
" into the new segments, marked, and threaded onto a list called
" "vector thread".  The lisp objects they contain are not
" processed by copylist.

copylist:	tsx7	already_seen
	tra	0,x4

cplistlp:
	tsx7	copycell

	epp1	pr3|2		"check cdr of currently copied cell.
	tsx7	already_seen
	tra	cdr_already_seen

	epp1	pr3|0
	tsx7	already_seen
	tra	car_seen_but_not_cdr

	" both car and cdr not seen yet. so thread old cell onto
	" continuation list.

	spri7	pr2|2
	epp7	pr2|0

car_seen_but_not_cdr:
	epp1	pr3|2	" proceed with cdr.
	tra	cplistlp

cdr_already_seen:
	epp1	pr3|0
	tsx7	already_seen	"check car.
	tra	ck_continuation	" both car and cdr have been seen, so stop with current list.

"	epp1	pr3|0	not needed because done just above.
	tra	cplistlp

ck_continuation:
	szn	pr7|0	" pr7 starts out pointing to a zero word.
	tze	0,x4

	" NOTE: following depends on hardware not looking at high order bits
	" in indirecting through a double-word.

	epp1	pr7|0,*
	epp7	pr7|2,*		" advance through continuation list.

	tsx7	test_cons	" we know it is a cons or atsym here.
	tra	ck_continuation
	tra	cplistlp

copycell:
	" Input: pr1 -> cons or atsym ptr to copy.
	" Output: pr2 = old address from object.
	"	pr3 = new object address.
	"	new object's car and cdr have been copied from old.
	"	pr1 -> copied address (new form of input object).
	" 	old object's car points to new object, and mark bit (sign bit)
	" 	is turned on.

	epp2	pr1|0,*

	lxl6	pr1|0		"check type (cons or atsym).
	canx6	Atsym,du
	tnz	copyatsym
copycons:
	epp3	pr5|2,ad	" allocate a cons cell.
	ttn	tally_out_on_cons
consalloc:spri3	pr1|0

	ldaq	pr2|0
	staq	pr3|0
	ldaq	pr2|2
	staq	pr3|2

	ldaq	pr1|0	"store new address with mark bit on.
	ora	=o400000,du
	staq	pr2|0	" in old cell.
	tra	0,x7

copyatsym:
	ldq	pr2|4	" get atsym pname length.
	adq	19,dl	" 15+4 (number of bytes to allocate in addition to cons part)
	qrl	4	"16 bytes per 4 words.

	epp3	pr5|2,ad
	ttn	tally_out_on_atsym
atsymalloc:
	eax0	pr5|2,ad	" NOTE: all atsyms require at least one loop.
	ttn	tally_out_on_atsym_lp
atsymalloc_lp:
	sbq	1,dl
	tpnz	atsymalloc

	ldq	pr2|4		" determine size to copy.
	adq	20,dl		" 20 bytes of stuff precede name.
	mlr	(pr,rl),(pr,rl)
	desc9a	pr2|0,ql
	desc9a	pr3|0,ql

	spri3	pr1|0
	ldaq	pr1|0
	ora	Atsym,dl
	staq	pr1|0
	ora	=o400000,du
	staq	pr2|0
	tra	0,x7

allocate_cells:	"called with tsx6, ql contains number cells -1, returns with pr0
		" pointing at allocated block.
	eax0	0,ql
	epp0	pr5|2,ad
	ttn	tally_out_on_allocate
alcellp:	eax0	-1,x0
	tmi	0,x6
	eax1	pr5|2,ad
	ttf	alcellp

tally_out_on_allocate:
	tsx5	tally_ran_out
	tra	alcellp
	tra	allocate_cells

tally_out_on_cons:
	tsx5	tally_ran_out
	tra	consalloc
	tra	copycons

tally_out_on_atsym:
	tsx5	tally_ran_out
	tra	atsymalloc
	tra	copyatsym
tally_out_on_atsym_lp:
	tsx5	tally_ran_out
	tra	atsymalloc_lp
	tra	copyatsym

tally_ran_out:			" skips if a new segment had to be made.
	aos	<lisp_alloc_>|[seg_blk_cntr]
	tmi	0,x5
get_initial_segment:
	spri	pr6|0
	sreg	pr6|32

	epp0	new_seg_ptr
	spri0	args+2
	ldaq	onearg
	staq	args
	epp0	args
	epbp7	pr6|0
	short_call	<lisp_segment_manager_>|[get_lists]

	lpri	pr6|0
	spri5	new_seg_ptr,*
	epp5	new_seg_ptr,*
	spri5	<lisp_alloc_>|[cur_seg]	" store away new allocation segment addresses.
	spri5	<lisp_alloc_>|[consptr]
	lda	=o2000053	" make consptr point up 2, and add in ad modifier.
	sta	<lisp_alloc_>|[consptr]+1
	lda	=o4740004
	sta	pr5|2
	lca	16,dl
	sta	<lisp_alloc_>|[seg_blk_cntr]
	lreg	pr6|32
	tra	1,x5

	end




		    lisp_old_io_.lisp               07/06/83  0937.8r w 06/29/83  1542.7       31518



;;; **************************************************************
;;; *                                                            *
;;; * Copyright, (C) Massachusetts Institute of Technology, 1973 *
;;; *                                                            *
;;; **************************************************************
;;; lisp_old_io_.lisp

;;; This module provides the lisp functions uread, uwrite, ufile, ukill, and crunit
;;; It is written in terms of the new I/O system.
;;; coded 27-MAR-73 by DAM
;;; fasload added 14 Nov 73 by DAM
;;; Modified 17 Sep 74 by DAM to not use fremob, add uprobe, uappend, uclose functions

(declare (system-file t))
(declare (special old-io-defaults uread uwrite infile outfiles))

(setq uread nil uwrite nil old-io-defaults nil)

(defun uread fexpr (x)
     (setq uread (openi (fetch-uread-names x)))
     (setq old-io-defaults (namelist uread))
     (eoffn uread (function
		(lambda (x y) x (setq uread nil) y)))	;provide for clearing of (status uread) on EOF
     (setq infile uread)		;make ^Q cause input from here
     (status crunit))


(defun fetch-uread-names (x)
     (mergef    (cond ((null x) '(*.*))
			((or (null (cdr x)) (null (cddr x))) (cons '* x))
			((list (cadddr x) (car x) (cadr x))) )
		(or old-io-defaults (namelist nil)) ))

(defun fasload fexpr (x)
    (setq x (fetch-uread-names x))
    (and (eq (car (last x)) 'fasl)	;drop fasl suffix
         (setq x (nreverse (cdr (reverse x)))) )
    (load x))



(defun uwrite fexpr (x)
     (and uwrite (setq outfiles (delq uwrite outfiles 1)))
     (or x (setq x (status crunit)))
     (setq uwrite (openo (mergef (list (cadr x) '!lisp 'output)		;temp file name !lisp.output until ufiled
			   (or old-io-defaults (namelist nil)) )))
     (apply 'crunit x)					;kludgey way to set the defaults
     (setq outfiles (cons uwrite outfiles))			;make this where output goes
     (status crunit))


(defun crunit fexpr (x)
	(or x (setq x (status crunit)))
	(setq old-io-defaults (mergef (cons (cadr x) '*) (or old-io-defaults (namelist nil))))
	x)


(defun ufile fexpr (x)
     (setq x (cond	(x (list (car x) (cadr x)))
		(old-io-defaults (cdr old-io-defaults)) ))
     (setq old-io-defaults (mergef (cons '* x) (or (namelist uwrite) old-io-defaults (namelist nil)) ))
     (errset (deletef old-io-defaults) nil)	;delete old copy if there
     (rename uwrite old-io-defaults)	;and rename to new copy
     (close uwrite)
     (setq uwrite nil)
     (status crunit))



(defun ukill fexpr (x)
     (setq x (cond ((null x) '(* . *))
	         ((null (cddr x)) (cons '* x))
	         ((list (cadddr x) (car x) (cadr x))) ))
     (setq old-io-defaults (setq x (mergef x (or old-io-defaults (namelist nil)) )))
     (setq x (deletef x))
     (list (cadr x) (caddr x)))

(defun uappend fexpr (x)
    (setq x (fetch-uread-names x))
    (and uwrite (setq outfiles (delq uwrite outfiles 1)))
    (setq old-io-defaults x)
    (setq x (rename x '(* !lisp !append)))
    (setq uwrite (opena x))
    (setq outfiles (cons uwrite outfiles))
    (status crunit))

(defun uprobe fexpr (x)
    (setq old-io-defaults (mergef (setq x (fetch-uread-names x)) (or old-io-defaults (namelist nil))))
    (not (not (allfiles x))))

(defun uclose nil
    (and uread (close uread))
    (setq uread nil))

;;;remob old-io_defaults because user must not play with it, and
;;;the compiler generated function !g1 that we happen to know is generated.

(remob 'old-io-defaults)(remob '!g1)(remob 'fetch-uread-names)

;;;end




		    lisp_oprs_.alm                  11/05/86  1612.7r w 11/04/86  1039.2      382023



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"		LISP Operators

" these operators provide run time support for compiled lisp functions
" they are called by tspbp through pointers in the lisp stack header

" Written by D A Moon 21 Aug 72
" modified 15 Oct 72 by DAM for some evidently secret reason
" modified 74.05.17 by DAM for "new" arrays and to speed up some oprs by using more pointer regs
" modified 74.12.06 by DAM for external arrays



	macro	enter_pl1_code
	epplp	ab|system_lp,*
	stx7	lisp_static_vars_$unmkd_ptr+1
	spriap	lisp_static_vars_$stack_ptr
	stc1	ab|in_pl1_code
	ife	&1,push
	push	&2
	eppbp	lisp_subr_tv_$..lisp..
	spribp	sp|stack_frame.entry_ptr
	ifend
	&end

	macro	exit_pl1_code
	ife	&1,pop
	eppbp	sp|0
	inhibit	on
	spribp	sb|stack_header.stack_end_ptr
	eppsp	sp|stack_frame.prev_sp,*
	inhibit	off
	ifend
	epbpab	lisp_static_vars_$unmkd_ptr,*
	eppap	lisp_static_vars_$stack_ptr,*
	ldx7	lisp_static_vars_$unmkd_ptr+1
	stz	ab|in_pl1_code
	&end

	equ	his_lp,-4			where on unmkd pdl caller's lp kept
	equ	his_bp,-2			where on unmkd pdl caller's
					" bp (= return addr) is kept
	equ	form,-8			dcl from lisp_
	equ	fcn,-6
	equ	argl,-4
	equ	plist,-2
	include	lisp_unmkd_pdl
	include	lisp_stack_seg
	include	lisp_array_fmt
	include	lisp_name_codes
	include	lisp_object_types
	include	stack_header
	include	stack_frame


" routine to set up operator pointers in the stack header
" called during initialization of the lisp environment,
" every time the 'lisp' command is issued.

	entry	init

init:	getlp
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*	-> stack header
	ldaq	gensym_init-*,ic
	staq	ab|gensym_data		" initialize data for gensym function.
	ldaq	fault_tag_3_number_1-*,ic	kill old array store pointer
	staq	ab|array_pointer
	eppbp	array_reference_op-*,ic
	spribp	ab|array_operator
	eppbp	dead_array_reference_op-*,ic
	spribp	ab|dead_array_operator
	eppbp	array_link_snap_op-*,ic
	spribp	ab|array_link_snap_opr
	eppbp	store_op-*,ic
	spribp	ab|store_operator
	eppbp	floating_store_op-*,ic
	spribp	ab|floating_store_operator
	ldaq	fault_tag_3_number_2-*,ic
	staq	ab|array_info_for_store
	eppbp	bind-*,ic
	spribp	ab|bind_op
	eppbp	unbind-*,ic
	spribp	ab|unbind_op
	eppbp	errset1-*,ic
	spribp	ab|errset1_op
	eppbp	errset2-*,ic
	spribp	ab|errset2_op
	eppbp	unerrset-*,ic
	spribp	ab|unerrset_op
	eppbp	call-*,ic
	spribp	ab|call_op
	eppbp	catch1-*,ic
	spribp	ab|catch1_op
	eppbp	catch2-*,ic
	spribp	ab|catch2_op
	eppbp	uncatch-*,ic
	spribp	ab|uncatch_op
	eppbp	iogbind-*,ic
	spribp	ab|iogbind_op
	eppbp	obscene_go_tag-*,ic
	spribp	ab|unseen_go_tag_op
	eppbp	throw1-*,ic
	spribp	ab|throw1_op
	eppbp	throw2-*,ic
	spribp	ab|throw2_op
	eppbp	signp-*,ic
	spribp	ab|signp_op
	eppbp	return-*,ic
	spribp	ab|return_op
	eppbp	err-*,ic
	spribp	ab|err_op
	sprilp	ab|system_lp		set up for later use.
	eppbp	pl1_interfacer-*,ic
	spribp	ab|pl1_interface
	eppbp	pl1_lsubr_interfacer-*,ic
	spribp	ab|pl1_lsubr_interface
	eppbp	<lisp_alloc_>|[cons_opr]
	spribp	ab|cons_op
	eppbp	<lisp_alloc_>|[ncons_opr]
	spribp	ab|ncons_op
	eppbp	<lisp_alloc_>|[xcons_opr]
	spribp	ab|xcons_op
	eppbp	<lisp_alloc_>|[begin_list_opr]
	spribp	ab|begin_list_op
	eppbp	<lisp_alloc_>|[append_list_opr]
	spribp	ab|append_list_op
	eppbp	<lisp_alloc_>|[terminate_list_opr]
	spribp	ab|terminate_list_op
	eppbp	compare
	spribp	ab|compare_op
	eppbp	link_operator
	spribp	ab|link_opr
	lda	fixnum_type,dl
	ldq	flonum_type,dl
	staq	ab|type_fields
	eppbp	<lisp_alloc_>|[cons_string]
	spribp	ab|cons_string_op
	eppbp	pl1_call_operator
	spribp	ab|pl1_call_op
	eppbp	create_string_descriptor
	spribp	ab|create_string_desc_op
	eppbp	create_varying_string
	spribp	ab|create_varying_string_op
	eppbp	create_array_descriptor
	spribp	ab|create_array_desc_op
	eppbp	unwind_protect-*,ic
	spribp	ab|unwp1_op
	spribp	ab|unwp2_op
	eppbp	unwind_protect_end
	spribp	ab|ununwp_op
	eppbp	irest_return
	spribp	ab|irest_return_op
	eppbp	pl1_call_nopop
	spribp	ab|pl1_call_nopop_op
	eppbp	rcv_char_star
	spribp	ab|rcv_char_star_op
	short_return
patch_instruction:
	tra	ab|call_op,*
	even
gensym_init:
	aci	"g"
	dec	0

""" Operators having to do with arrays.

	even
fault_tag_3_number_1:
	arg	1,f3
	arg	0
fault_tag_3_number_2:
	arg	2,f3
	arg	0

array_reference_op:
	epplb	ab|system_lp,*			check for *rset t mode
	link	star_rset,<lisp_static_vars_>|[star_rset],*
	ldaq	lb|star_rset,*
	epplb	bb|array_data_ptr-2,*		-> array_data block (dope vector)
	lxl4	bb|array_info.2ndims-2		number of subscripts * -2
	tze	external_array_reference-*,ic		tra if ext array flag set
	cmpaq	ab|nil
	tnz	array_ref_with_full_checking-*,ic

array_ref_without_checking:
	eaq	0				compute offset in q

	adq	ap|1,x4				add in a subscript
	mpy	lb|1,x4				multiply by multiplier
	eax4	2,x4
	tnz	-3,ic

	lxl4	bb|array_info.2ndims-2		pop subscripts off stack
	eppap	ap|0,x4				..

	spribb	ab|array_info_for_store		save data for store
	stq	ab|array_offset_for_store
	tra	bb|array_load_sequence-2		use code in array to load and return

array_ref_with_full_checking:

array_checking_loop:
	ldaq	ap|0,x4				get a subscript
	cmpa	fixnum_type,dl			fixnum?
	tnz	bad_subscript-*,ic			no, barf
	cmpq	lb|0,x4				compare against bounds
	trc	bad_subscript-*,ic			out of bounds or negative
	eax4	2,x4
	tnz	array_checking_loop-*,ic
	lxl4	bb|array_info.2ndims-2		number of subscripts * -2
	tra	array_ref_without_checking-*,ic	reference is OK, proceed.

external_array_reference:
	cmpaq	ab|nil
	tze	ext_array_ref_no_check-*,ic
	ldaq	ap|-2			check bound
	cmpa	fixnum_type,dl
	tnz	bad_subscript-*,ic
	cmpq	bb|array_load_sequence-2	which is stored in kludgey way
	trc	bad_subscript-*,ic		out of bounds or negative
ext_array_ref_no_check:
	ldq	ap|-1			get subscript
	eppap	ap|-2			pop subscript
	spribb	ab|array_info_for_store	save data for store
	stq	ab|array_offset_for_store
	lda	fixnum_type,dl		ext arrays are always fixnum
	tra	bb|array_load_sequence-2+1	use code in array to load and return

bad_subscript:
	lxl1	<lisp_error_table_>|[bad_array_subscript]	better not need lp
array_reference_err:
	eppap	ap|4		get set to push args to lisp_error_
	staq	ap|-2		the bad subscript
	eppbb	bb|-2		the array pointer
	spribb	sb|stack_header.stack_end_ptr,*
	ldaq	sb|stack_header.stack_end_ptr,*
	ora	Array+35,dl	turn on array type bit and its tag
	staq	ap|-4
	ldaq	ap|-2		make list of array pointer and subscript
	tspbp	ab|ncons_op,*
	spribb	ap|-2
	ldaq	ap|-4
	tspbp	ab|cons_op,*
	ldaq	ap|-2
	staq	bb|2
	eppap	ap|-2
	spribb	ap|-2
	eaa	0,x1		get error code.
	arl	18
	lcq	-fn_store,dl	if fn code requuired, was store
	tsx0	Lisp_Error-*,ic	go signal uncorrectable error.

dead_array_reference_op:
	eppap	ap|2		will pass array pointer to lisp_error_
	eppbb	bb|-2		the array pointer
	spribb	sb|stack_header.stack_end_ptr,*
	ldaq	sb|stack_header.stack_end_ptr,*
	ora	Array+35,dl
	staq	ap|-2
	lda	<lisp_error_table_>|[dead_array_reference]	better not need lp
	ldx1	bb|array_info.type-2	perhaps is really a readtable
	cmpx1	Readtable_array,du
	tnz	2,ic
	 lda	 <lisp_error_table_>|[cant_subscript_readtable]	better not need lp
	tsx0	Lisp_Error-*,ic	go signal uncorrectable error.


""" compiled store comes here.  locations in stack header have been set up
""" by a previous array reference.  value to store is in aq. (or just q if
""" compiler knows it to be a fixnum or flonum array)

store_op:	eppbb	ab|array_info_for_store,*	-> array_info, fault if bad.
	lxl1	ab|array_offset_for_store	get index value
	ldx0	bb|array_info.type-2	get array type
	xec	store_table,x0		do store seq. depending on type
	tra	bp|0			and return.  aq is unchanged.

store_table:
	staq	bb|array_data_ptr-2,*x1	S-expr array
	staq	bb|array_data_ptr-2,*x1	Un-gc array
	stq	bb|array_data_ptr-2,*x1	fixnum array
	stq	bb|array_data_ptr-2,*x1	flonum array
	tra	not_allowed_to_store	readtable
	tra	not_allowed_to_store	obarray
	tra	store_into_dead_array	dead.

" operator similar to store_op but value to be stored is in EAQ.
" type checking is performed.

floating_store_op:
	eppbb	ab|array_info_for_store,*
	lxl1	ab|array_offset_for_store
	ldx0	bb|array_info.type-2
	xec	floating_store_table,x0
	tra	bp|0

floating_store_table:
	tra	move_EAQ_to_Q_then_store
	tra	move_EAQ_to_Q_then_store
	tra	not_allowed_to_store_f		flonum -> fixnum array
	fstr	bb|array_data_ptr-2,*x1		flonum -> flonum array
	tra	not_allowed_to_store_f
	tra	not_allowed_to_store_f
	tra	not_allowed_to_store_f

not_allowed_to_store_f:
	eax7	2,x7
	fstr	ab|-1,x7
	ldq	ab|-1,x7
	lda	flonum_type,dl
	tra	not_allowed_to_store-*,ic

move_EAQ_to_Q_then_store:
	eax7	2,x7
	fstr	ab|-1,x7
	ldq	ab|-1,x7
	lda	flonum_type,dl
	eax7	-2,x7
	staq	bb|array_data_ptr-2,*x1
	tra	bp|0

not_allowed_to_store:  store_into_dead_array:
	lxl1	<lisp_error_table_>|[store_not_allowed]		better not need lp
	tra	array_reference_err-*,ic


""" This operator is used by compiled code to get an array pointer
""" from an atomic symbol which is alleged to be the name of an array
""" It is called by xec'ing a 4-word block in the comp_subr_block,
""" which contains a tspbp to this operator
""" and a word in the form  vfd 9/type,9/ndims,18/constant
""" constant is the offset relative to lp (in the constants area)
""" of the atomic symbol which names the array.
""" The first word in the block is changed to eppbb *+2,*
""" and the last words are changed to point to the array_info block.

""" Registers:
"""	lp = caller's lp
"""	bp -> calling xec instruction + 1
"""	lb = system lp
"""	bb = clobberable, set on return to -> array_info
"""	aq and x5 are unchanged.

	link	array_atom,<lisp_static_vars_>|[array_atom]
	link	no_snapped_links_flag,<lisp_static_vars_>|[no_snapped_links]

array_link_snap_op:
	epplb	ab|system_lp,*
	eppap	ap|2		save aq
	staq	ap|-2
	ldx1	bp|-1		-> array_link block (relative to lp)
	anx1	=o077777,du
	lxl0	lp|1,x1		offset from lp to symbol naming array
	eppbb	lp|0,x0*		-> symbol
continue_array_search:
	ldaq	bb|2
	cana	lisp_ptr.type,dl	end?
	tnz	couldnt_snap_array_link-*,ic
	eppbb	bb|2,*		next piece of property list
	ldaq	bb|0
	cmpaq	lb|array_atom,*
	tnz	continue_array_search-*,ic
	eppbb	bb|2,*
	eppbb	bb|0,*		array pointer
	ldx0	lp|1,x1		ndims
	anx0	=o000777,du
	cmpx0	bb|array_info.ndims
	tnz	couldnt_snap_array_link-*,ic
	lda	lp|1,x1		get required type
	arl	27
	tze	check_for_Sexpr_array-*,ic
	eax0	0,al
	cmpx0	bb|array_info.type	check against actual type
	tnz	couldnt_snap_array_link-*,ic
could_snap_array_link:
	spribb	lp|2,x1		snap the link
	stz	lb|no_snapped_links_flag
	eaa	-1
	ansa	lp|-6		turn off flags for unlinker
	eaa	2,x1
	ora	link_snap_instruction-*,ic
	sta	lp|0,x1		put in eppbb instruction
	ldaq	ap|-2		restore aq
	eppap	ap|-2
	tra	bp|0		exit.  bb has been set.

link_snap_instruction:  eppbb lp|0,*

check_for_Sexpr_array:
	ldx0	bb|array_info.type
	szn	ok_to_link_table,x0
	tnz	could_snap_array_link-*,ic
couldnt_snap_array_link:
	lxl0	lp|1,x1
	ldaq	lp|0,x0		name of array
	eppap	ap|2
	staq	ap|-2
	lda	<lisp_error_table_>|[not_an_array]		better not need lp
	eaq	0		"function ? wanted an array, not foo"
	tra	Lisp_Error-*,ic


ok_to_link_table:
	vfd	36/1,36/1,36/0,36/0,36/0,36/1,36/0

""" Interpreted store function.  similar to store operator
"""	but makes more checks.

	segdef	store

store:	eppap	ap|4		extract args from arglist (fsubr)
	eppbb	ap|-6,*		-> arglist
	ldaq	bb|2,*		cadr is 2nd arg
	staq	ap|-2
	ldaq	bb|0		car is 1st arg
	staq	ap|-4
	eax7	8,x7		going to make two calls to eval
	sprilp	ab|his_lp,x7
	eax5	-2
	stcd	ab|his_bp,x7
	tra	<lisp_>|[eval_]	evaluate 2nd arg
	staq	ap|-4		save the value to be stored
	sprilp	ab|his_lp,x7
	eax5	-2
	stcd	ab|his_bp,x7
	tra	<lisp_>|[eval_]	evaluate first arg (array reference)

	ldaq	ap|-2		pick up value to be stored
	eppap	ap|-2		clear the stack
	eppbb	ab|array_info_for_store,*	get ptr to array_info block
	lxl1	ab|array_offset_for_store	get subscript
	ldx0	bb|array_info.type-2	check type of array and of value to store
	xec	store_test,x0
	tnz	not_allowed_to_store-*,ic	type mismatch
	xec	store_table,x0	OK to store, do so.
	tra	return-*,ic

store_test:
	eax2	0		S-expr - can always store
	eax2	0		Un-gc - can always store
	cmpa	fixnum_type,dl	Fixnum
	cmpa	flonum_type,dl	Flonum
	tra	not_allowed_to_store  Readtable
	tra	not_allowed_to_store  Obarray
	tra	store_into_dead_array Dead

""" Routine to signal a LISP error

Lisp_Error:
	eax7	8,x7		save bp, lp, bb, lb, x0, and room to push error code.
	sprpbp	ab|-8,x7
	sprplp	ab|-7,x7
	sprpbb	ab|-6,x7
	sprplb	ab|-5,x7
	stx0	ab|-4,x7

	staq	ab|-2,x7		error code, fn code

" prepare to call pl1 program

	enter_pl1_code	push
	eppap	null_argl-*,ic		pass no args to pl1 error routine.
	short_call lisp_error_$lisp_error_
	exit_pl1_code	pop

	ldx0	ab|-2,x7		restore saved registers
	lprplb	ab|-3,x7
	lprpbb	ab|-4,x7
	lprplp	ab|-5,x7
	lprpbp	ab|-6,x7
	eax7	-6,x7

	tra	0,x0		return from call to Lisp_Error

" two routines which are the operators for pl1 compiled subrs.
" These routines generate a standard Multics call, and keep track
" of the lisp stacks so that interrupts can be handled correctly.
" The calling sequence, which appears in the subr block in the lisp
" static storage segment, is:
"
"	eax7	2,x7
"	spribp	ab|-2,x7
"	tspbp	ab|pl1_interface_op,*	for the appropiate interface....
"	its	<routine>			link to routine....
"
pl1_lsubr_interfacer:
	eppap	ap|2			get room for saving x5.
	eaq	0,x5
	qrs	18
	lda	fixnum_type,dl
	staq	ap|-2
pl1_interfacer:
	eax7	4,x7			get room to save lp
	sprilp	ab|-4,x7			save callers lp
	epplp	bp|0,*			get pointer to pl1 entry to call.
	sprilp	ab|-2,x7			and save through the save sequence.
	enter_pl1_code	push
	eppbp	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	null_argl-*,ic			must set up arg list.
	short_call bp|-2,*			call the target fo the call.
	exit_pl1_code	pop
	epplp	ab|-4,x7*
	eppbp	ab|-6,x7*
	eax7	-6,x7
	ldaq	ap|-2
	eppap	ap|-2
	tra	bp|0
	even
null_argl:oct	4,0



" link opertor for compiled code

link_operator:
	eax7	8,x7
	sprplp	ab|-8,x7
	stx0	ab|-7,x7
	sxl5 	ab|-7,x7
	eppbp	lp|-1
	adwpbp	bp|0		" get pointer to itp.
	spribp	ab|-6,x7
	eppbp	ab|-6,x7
	spribp	ab|-2,x7
	ldaq	one_arg
	staq	ab|-4,x7
	enter_pl1_code	push
	eppap	lisp_static_vars_$unmkd_ptr,*
	eppap	ap|-4
	short_call lisp_linker_$lisp_linker_
	exit_pl1_code	pop
	lprplp	ab|-8,x7
	ldx0	ab|-7,x7
	lxl5	ab|-7,x7
	eppbp	ab|-6,x7*
	eax7	-8,x7
	tra	bp|0,*

one_arg:	zero	2,4
	zero	0,0

" bind operator.
" the calling tspbp is followed by a word with 4*number bindings in
" left half
" Following this is one word for each binding, in the form:
"	vfd	3/flags, 15/atom_loc, 18/value_loc
" where atom_loc is offset from lp of ptr to atom, value_loc is
" offset of new value to be given it, flags tells where value_loc
" is offset from: 0=ab, 1=ap, 2=lp, 3=addr of this word (bp)
"    If flags is >3, means one of these special cases:
"	4  bind the argatom according to x5 (for compiled lexpr's)
"			(atom_loc better be 0!!!)
"	5  obtain value from x5 (for compiled lexpr's)
"	6  same as 1 except take the car of the value
"	7  same as 2 except take the car of the value
"
"   NB: offset from ap is from ap after 4*number_bindings
"       has been added to it.
" The marked pdl portion of the binding block is allocated
" by this operator, and the unmarked pdl portion
" must be allocated here.
" this operator destroys the contents of aq and all the index registers
"
" Usage of index registers in this operator:
"
" x0   not used
" x1   temp.
" x2   saves value of ap when operator was called
" x3   counts number of bindings to be done
" x4   points at current 4-word slot in binding block
" x5   not changed, for flags = 4 or 5, should be -2*#args to lsubr
" x6   temp
" x7   unmarked pdl ptr, as usual
"
" Pointer Registers
"
" bp -> control words in caller
" lp    left as caller's lp
" lb    system lp
" bb    temporary


	link	binding_top_plus_1,<lisp_static_vars_>|[binding_top]+1
	link	argatom,<lisp_static_vars_>|[argatom]

bind:
	eax7	2,x7			room for binding block
	epplb	ab|system_lp,*
	ldx3	bp|0			4*number_bindings
	lcx4	bp|0			offset of first binding from top of stack
	eax2	ap|0			save ap in case of flags=4
	eppap	ap|0,x3			make room for binding block.
	ldq	lb|binding_top_plus_1,*	make binding block
	stq	ab|-1,x7			binding_block.back_ptr (clear rev_ptr)
	stx2	ab|-2,x7			set binding_block.top_block
	sxl2	ab|-2,x7			set binding_block.bot_block
	eax1	ab|-2,x7			and thread onto list of binding blocks
	stx1	lb|binding_top_plus_1,*

bind_loop:
	eppbp	bp|1			-> next binding descrip word
	ldx1	bp|0			get atom to be bound
	anx1	=o077777,du
	tze	flags4-*,ic		not an atom (for flags=4)
	ldaq	lp|0,x1
	staq	ap|2,x4
	ldaq	ap|2,x4*
	staq	ap|0,x4			save old value
	eax4	4,x4			-> next slot in binding block
	eax1	ap|0,x4			update binding_block.top_block
	stx1	ab|-2,x7
	lxl1	bp|0			get new value to give to atom
	lda	bp|0			use 'flags' as xec vector index
	arl	15
	xec	bind_vec,au		get new value in aq
xec_ret:
	staq	ap|2-4,x4*
	eax3	-4,x3			count bindings
	tnz	bind_loop-*,ic
	tra	bp|1			all done

bind_vec:
	ldaq	ab|0,x1
	ldaq	ap|0,x1
	ldaq	lp|0,x1
	ldaq	bp|0,x1
	tra	flags4			4  - special case
	tra	flags5			5  - get value from x5 reg.
	ldaq	ap|0,x1*
	ldaq	lp|0,x1*


flags5:	eaa	0,x5			get -2*nargs
	neg	0
	lrs	19+36			c(q) = nargs
	lda	fixnum_type,dl
	tra	xec_ret-*,ic

flags4:	eax4	4,x4			adjust x4 for next binding
	epaq	lb|argatom,*		-> argatom
	eaa	0,au			clear ring number
	ora	Uncollectable+35,dl		type bit and its tag
	staq	ap|2-4,x4			put in binding block
	ldaq	ap|2-4,x4*		save old value
	staq	ap|0-4,x4
	eax6	ap|0,x4			update binding_block.top_block
	stx6	ab|-2,x7
	eaa	0,x5			-2 * nargs
	neg	0
	ars	1			nargs to au
	ora	Uncollectable,dl		special kludge thing argatom is bound to
	eppbb	ap|2-4,x4*		-> value cell of argatom
	sta	bb|0			store first word
	lxl1	bp|0			stack offset due to compiled code
	stx1	bb|1			build up second word.
	asx2	bb|1			stack pointer when operator called
	asx5	bb|1			stack offset to get to arguments
	tra	xec_ret+1-*,ic		and return to normal sequence


" unbind operator.
" unbinds the binding block which must be located at top of unmkd pdl
"preserves aq but
" changes index registers, decrements x7 by 2, 
" de-allocates the binding block allocated by bind operator, hence changes ap


unbind:	eax7	4,x7		save aq + temp.
	staq	ab|-4,x7
	epplb	ab|system_lp,*
	lxl1	ab|-6,x7			binding_block.bot_block
	stx1	ab|-1,x7			save for cmpx1
	eax6	0,x1			save base of binding block for eppap below.
	epbpbb	ap|0			baseptr of marked pdl
	ldx1	ab|-6,x7			binding_block.top_block

" now proceed to unbind top down

unbind_loop:
	cmpx1	ab|-1,x7			reached bottom?
	tze	unbind_end-*,ic		 yes.
	eax1	-4,x1			 no, do next.
	ldaq	bb|0,x1			get old value
	staq	bb|2,x1*			put back on atom
	tra	unbind_loop-*,ic		and keep it up.

unbind_end:
	ldx1	ab|-5,x7			unthread this binding block
	stx1	lb|binding_top_plus_1,*
	eppap	bb|0,x6			pop binding block storage off of marked pdl
	ldaq	ab|-4,x7			restore aq
	eax7	-6,x7			clear save area and binding_block from pdl
	tra	bp|0			& return

" errset1 operator.
" sets up an errset with no suppression of error messages
" destroys contents of x0-x6 and aq. x7 is bumped by 12,
" ap is bumped by 2.
" *** 22 SEP 72 - DAM -- no longer makes a stack frame,
" just saves the rtcd loc in the stack frame, which is destroyed
" by the Multics non local go to mechanism.

" call is:
"	tspbp	ab|errset1,*
"	tra	eob			return here if error occurs
"					"with nil or value of err in aq
"	- compiled first arg to errset -
" eob:	tspbp	ab|unerrset,*


errset1:	eppap	ap|2			temp for use if error occurs
	eax2	0			this is not errset with nil 2nd arg
	tra	errset_com-*,ic


" errset2 operator.
" sets up an errset with 2nd arg to errset determining
" suppression of error messages. destroys contents of aq
" and x0-x6, x7 is bumped by 12, ap is unchanged. Call is
" same as errset1 except that top of marked pdl
" contains evaluated second arg to errset.


errset2:	ldaq	ap|-2			get 2nd arg to errset
	cmpaq	ab|nil			if nil, suppress error msgs
	tnz	errset1+1-*,ic		not nil, allow msgs
	ldx2	=o400000,du		nil, set x2 to "1"b

errset_com:
	eax7	12,x7			size(frame)+save lp,bp,sp|20
	sprilp	ab|his_lp,x7
	spribp	ab|his_bp,x7		save caller's stuff for return
	epplp	ab|system_lp,*
	ldaq	sp|20			save ret addr in stack frame we are sharing
	staq	ab|-6,x7

" set up errset frame on unmarked pdl
" above errset frame our caller's lp, bp will be
" saved so that error routine can return to him.

	eax1	ap|0
	sxl1	ab|frame.stack_ptr-12,x7
	ldx1	<lisp_static_vars_>|[err_frame]+1
	stx1	ab|frame.prev_frame-12,x7
	stz	ab|frame.dat2-12,x7		set to "1"b by err if eval needed
	stx2	ab|frame.dat1-12,x7		set suppress-msgs flag
	eppbp	err_return-*,ic
	spribp	ab|frame.ret-12,x7
	sprisp	ab|frame.ret+2-12,x7
	eax1	ab|-12,x7
	stx1	<lisp_static_vars_>|[err_frame]+1

" return to compiled first arg to errset

	epplp	ab|his_lp,x7*
	eppbp	ab|his_bp,x7*
	tra	bp|1

" come here if error occurs, value to return is on top of
" marked pdl, frame.dat2 is "1"b if it hasn't been evaled yet (from fcn 'err')

err_return:
	getlp			" in pl1 code mode, must get lp from lot.
	push				"stack frame to call out with
	eppbp	<lisp_static_vars_>|[unmkd_ptr],*    push onto unmkd pdl...
	eppbp	bp|2
	spribp	<lisp_static_vars_>|[unmkd_ptr]
	eppap	<lisp_static_vars_>|[err_frame],*
	eppap	ap|12			... the addr to unwind to
	spriap	bp|-2			which is just above our errset frame
	eppbp	<lisp_static_vars_>|[stack_ptr],*    copy value to be returned down
	lxl1	ap|frame.stack_ptr-12
	ldaq	bp|-2
	epbpbb	bp|0
	staq	bb|-2,x1
	eppap	null_argl-*,ic		get null arg list for call.
	short_call  <lisp_prog_fns_>|[lisp_unwinder]
	eppbp	<lisp_static_vars_>|[err_frame],*  should we eval the returned value?
	lxl1	bp|frame.stack_ptr
	epbpab	<lisp_static_vars_>|[stack_ptr],*
	eppap	ab|0,x1
	spriap	<lisp_static_vars_>|[stack_ptr]
	lxl0	bp|frame.dat2
	tze	err_ret_0-*,ic
	eppap	null_argl-*,ic		get null arg list for call to pl1 entry in eval.
	short_call  <lisp_>|[eval]
err_ret_0:

" now go from pl1_code mode to lisp_code mode, and
" return to error return loc in errset caller, with errset frame still around

	exit_pl1_code	pop
	ldaq	ab|-6,x7			restore ret addr in stack frame
	staq	sp|20
	epplp	ab|his_lp,x7*
	eppbp	ab|his_bp,x7*
	ldaq	ap|-2			value of the errset
	tra	bp|0			return to caller, who will do an unerrset.
 
" unerrset operator.
" this operator removes the errset frame which must be at the top of
" the unmarked pdl.  It does not disturb the aq or the ap, it
" decrements x7 by 12, and the other index registers are destroyed.
" doesn't have to restore sp|20 since that is only
" destroyed by a non-local goto and our non-local-goto reciever has
" already fixed it.

	link	err_frame_plus_1,<lisp_static_vars_>|[err_frame]+1

unerrset:
	epplb	ab|system_lp,*		get lp for this program.
	ldx1	ab|frame.prev_frame-12,x7	remove err frame from pdl
	stx1	lb|err_frame_plus_1,*
	eax7	-12,x7
	eppap	ap|-2		get rid of value pushed on by caller.
	tra	bp|0


" call operator.
" this operator is used to provide call_outs from lisp-compiled
" code to external functions.  It is called by tspbp lp|link,*
" where the doubleword link in the linkage section is:

" link:	vfd  3/ab, 15/fcn_offset, 1/snap, 1/constant, 1/fsubr, 9/nargs, 6/itb
"	vfd  18/call_oper, 12/0, 6/20
" where fcn_offset is offset from ap (constant = 0)
"  or from lp (constant = 1)
" snap is 1 if the link is to be changed to point directly
"  at the function if possible
" fsubr is 1 if the top of the pdl contains the unevaluated
"  list of args, 0 if top of pdl contains spread, evaluated args
" nargs is o777 if arg count times -2 is in x5, otherwise is arg count
" the remaining fields look like  itb  ab,call_oper,*
" so that the tspbp has the effect of tspbp ab|call_oper,*
" this operator destroys all the index registers, it returns
" with x7 unchanged, result of function in aq, and the
" args or arglist popped off the marked pdl.


call:	eax7	6,x7		push lp, bp, addr of link
	sprilp	ab|his_lp,x7
	spribp	ab|his_bp,x7
	ldx0	bp|-1		get addr of link
	anx0	=o077777,du
	eppbp	lp|0,x0
	spribp	ab|-6,x7
	lda	bp|0		get the function into aq
	als	3		spread sign bit (3) into (0-2)
	ars	3
	cana	=o200000,dl	test constant bit
	tnz	3,ic
	ldaq	ap|0,au		not constant, get from stack
	tra	2,ic
	ldaq	lp|0,au		constant, get from linkage section
	eppap	ap|-form
	staq	ap|form
	lda	bp|0			check for f_type function
	cana	=o100000,dl
	tnz	call_2_f-*,ic
	epplp	ab|system_lp,*


" set x5 to number of args if not already so set

	lda	ab|-6,x7*
	ana	=o77700,dl
	cmpa	=o77700,dl
	tze	already_got_x5-*,ic
	  ars	  5
	  neg	  0
	  eax5	  0,al
already_got_x5:

" go to routine in lisp_ to do rest of work

	tra	<lisp_>|[call1]

" call with unevaled arg list

call_2_f:
	ldaq	ap|form-2			arg list
	eppap	ap|-2
	staq	ap|argl
	ldaq	ap|fcn
	staq	ap|form
	epplp	ab|system_lp,*
	tra	<lisp_>|[callf]


" catch1 operator.
" is the compiled form of a catch with one argument
" destroys contents of aq and x0-x6, x7 is bumped by 12,
" ap is bumped by 2.
" call is:
"	tspbp	ab|catch1,*
"	tra	eoc			return here if throw occurs
"					with the value thrown in aq
"	- compiled first arg to catch -
" eoc:	tspbp	ab|uncatch,*
"	"result of catch is now in aq
"
" also saves sp|20 and restores it if it gets destroyed
" by unwinder_



catch1:	eppap	ap|2			make fake catch tag
	ldaq	nultag-*,ic
	staq	ap|-2
					" fall into catch2



" catch2 operator.
" is compiled form of catch with a second arg, which is the catch tag.
" call is same as catch1 except ap is not bumped and top of marked pdl
" contains the unevaluated second arg to catch.


catch2:
	eax7	12,x7
	sprilp	ab|his_lp,x7
	spribp	ab|his_bp,x7
	epplp	ab|system_lp,*
	ldaq	sp|20			save ret addr in stack frame we are sharing
	staq	ab|-6,x7

" set up catch frame on unmarked pdl.  Above the
" catch frame our caller's lp, bp will be saved
" so that we can return to him if a throw occurs.

	eax1	ap|0			-> just above catch label (for throw)
	sxl1	ab|frame.stack_ptr-12,x7
	ldx1	<lisp_static_vars_>|[catch_frame]+1
	stx1	ab|frame.prev_frame-12,x7
	eppbp	throw_ret-*,ic
	spribp	ab|frame.ret-12,x7
	sprisp	ab|frame.ret+2-12,x7
	eax1	ab|-12,x7
	stx1	<lisp_static_vars_>|[catch_frame]+1

" go elaborate the compiled first arg to catch

	epplp	ab|his_lp,x7*
	eppbp	ab|his_bp,x7*
	tra	bp|1


" come here (in pl1_code mode) if a throw occurs.  The value
" thrown is at top of marked pdl.  The unmarked pdl has not
" yet been unwound.
" We move the thrown value down, unwind the unmarked pdl to
" just above our catch_frame, put the thrown value
" in aq, and return to the location after
" the call to catch1 or catch2.  The caller will do an uncatch.

throw_ret:
	getlp				" get lp from lot, as we are in pl1 code mode here.
	push
	eppbp	<lisp_static_vars_>|[unmkd_ptr],*
	eppbp	bp|2			push onto unmarked pdl...
	spribp	<lisp_static_vars_>|[unmkd_ptr]
	eppap	<lisp_static_vars_>|[catch_frame],*
	eppap	ap|12			...the addr to unwind to...
	spriap	bp|-2			...which is just above our catch frame
	eppbp	<lisp_static_vars_>|[stack_ptr],*
	ldaq	bp|-2			get the thrown value
	lxl1	ap|frame.stack_ptr-12
	epbpbb	bp|0
	staq	bb|-2,x1			and put it into our part of marked pdl
	eppap	null_argl-*,ic		call the unwinder with no pl1 arguments.
	short_call  <lisp_prog_fns_>|[lisp_unwinder]

" switch to lisp_code mode (ptrs in ap, x7)

	exit_pl1_code	pop
	epbpbb	ap|0			adjust stack_ptr to value when catch wsa done
	lxl1	ab|frame.stack_ptr-12,x7
	eppap	bb|0,x1
	ldaq	ab|-6,x7			restore sp|20
	staq	sp|20
	ldaq	ap|-2			return thrown value in aq
	epplp	ab|his_lp,x7*
	eppbp	ab|his_bp,x7*
	tra	bp|0			return to caller who will do an uncatch



" uncatch operator.
" this operator removes the catch frame which must be at the top
" of the unmarked pdl.  It does not disturb the aq or the ap,
" it decrements x7 by 12, and the other index registers are
" destroyed.

	link	catch_frame_plus_1,<lisp_static_vars_>|[catch_frame]+1

uncatch:	epplb	ab|system_lp,*
	ldx1	ab|frame.prev_frame-12,x7	unthread this catch_frame
	stx1	lb|catch_frame_plus_1,*
	eax7	-12,x7
	eppap	ap|-2		get rid of value pushed by caller.
	tra	bp|0

 
" operator to bind for iog.  Allows iog to be compiled as
"	tspbp	ab|iogbind_op,*
"	<call>	<function ioc>
"	<eval>	2nd arg to iog
"	tspbp	ab|unbind_op,*
"
" binds ^q, ^r, ^w to nil.
" destroys the contents of aq and all the index registers, bumps x7 by 2
" bumps ap by 16, but only 12 of those words are currently used.

	
iogbind:	eax7	6,x7			room for binding block, save lp,bp
	sprilp	ab|his_lp,x7
	spribp	ab|his_bp,x7
	epplp	ab|system_lp,*
	eppap	ap|16			make room for binding block
	ldaq	ab|true			" KLUDGE to take up space...rebind t to t.
	staq	ap|-14
	staq	ap|-16			" END KLUDGE
	ldaq	<lisp_static_vars_>|[ctrlQ]	put ^q in binding block
	staq	ap|-10
	ldaq	<lisp_static_vars_>|[ctrlR]	put ^r in binding block
	staq	ap|-6
	ldaq	<lisp_static_vars_>|[ctrlW]	put ^w in binding block
	staq	ap|-2
	ldaq	ap|-10,*			now save old values.
	staq	ap|-12
	ldaq	ap|-6,*
	staq	ap|-8
	ldaq	ap|-2,*
	staq	ap|-4
	ldq	<lisp_static_vars_>|[binding_top]+1
	stq	ab|-5,x7			make binding_block in unmkd pdl
	eax1	ap|-16
	sxl1	ab|-6,x7			binding_block.bot_block
	eax1	ap|0
	stx1	ab|-6,x7			binding_block.top_block
	eax1	ab|-6,x7			and thread onto list of b.b.'s
	stx1	<lisp_static_vars_>|[binding_top]+1


	ldaq	ab|nil			now reset ^q, ^r, ^w to nil
	staq	<lisp_static_vars_>|[ctrlQ],*
	staq	<lisp_static_vars_>|[ctrlR],*
	staq	<lisp_static_vars_>|[ctrlW],*

	tra	return-*,ic



" unseen_go_tag operator
" this operator is called by the compiled form of the go function
" when the argument is non-atomic and, having been evaled, is not
" found in the table of known tags.
" Called by tspbp with the losing tag in the aq.  Returns with
" ap, x7 unchanged, better tag in the aq, index regs destroyed.
"
" If the aq contains an atom, it is really a losing tag
" and a call to lisp_error_ is constructed.
" If the aq contains a list, then it is evaluated and returned
" to caller, just like the interpreted go function.

obscene_go_tag:
	eax7	4,x7			save caller's lp,bp
	spribp	ab|his_bp,x7
	sprilp	ab|his_lp,x7
	eppap	ap|2			save tag on pdl for lisp_error_ or eval
	staq	ap|-2
	cana	lisp_ptr.type,dl		atomic tag?
	tze	re_eval_tag-*,ic		no, eval it again.
	lda	<lisp_error_table_>|[unseen_go_tag]
	tsx0	Lisp_Error-*,ic
	ldaq	ap|-2			get replacement tag
	eppap	ap|-2
	tra	return-*,ic

" come here to eval the tag again

re_eval_tag:
	eax5	-2			calling eval with 1 arg
	epplp	ab|system_lp,*		get right lp for eval
	tra	<lisp_>|[eval_]		eval the tag and return to our caller. (clever)


" return operator.
" called by tra ab|return_op,*
" This operator is used to return from a type 1 subr
" after the unmkd pdl has been cleared, and the args, temps,
" and local variables have been removed from the marked pdl.
" the value to be returned should be in the aq.

return:	epplp	ab|his_lp,x7*
	eppbp	ab|his_bp,x7*
	eax7	-4,x7
	tra	bp|0





" signp operator.
" called by tspbp ab|signp_op,*
" This operator sets the indicators from the number in the aq.
" If C(aq) is not a number, indicators are set randomly.
" Changes no registers except aq.

signp:	cana	Float,dl			flonum?
	tnz	signp_fl-*,ic		yes.
	cana	Big_fixed,dl		bignum?
	tnz	signp_big-*,ic

" fixnum - set indicators from q<0:35>

	cmpq	0,du			set indicators for fixnum in q.
	tra	bp|0

" flonum - set indicators from fraction, q<8:35>

signp_fl:	canq	=o1000,du			set zero indicator from sign bit of float.
	tnz	set_minus_indicator-*,ic	and if negative float, set negative indicator.
	cmpq	=0.0,du			otherwise, compare with floating point zero (= least fixed number)
	tra	bp|0
set_minus_indicator:
	szn	=o777777,du		turn on minus indicator.
	tra	bp|0			return.

signp_big: easpbb	0,au			move pointer from AQ to BB
	eawpbb	0,qu			..
	szn	bb|0			get sign from bignum.  works because
	"				no bignum is zero, and RH of header is nonzero
	tra	bp|0

" compare operator.
" takes arg in AQ, bb points at thing to be compared with.
" sets indicators, returns.

compare:	cmpa	fixnum_type,dl
	tnz	floatcomp
	cmpq	bb|1
	tra	bp|0		return

floatcomp:eppap	ap|2
	staq	ap|-2
	fld	ap|-1
	eax0	1
	fcmp	bb|1
	tpnz	4,ic
	tze	2,ic
	eax0	-1,x0
	eax0	-1,x0
	ldaq	ap|-2		" reload the aq.
	eppap	ap|-2
	cmpx0	0,du
	tra	bp|0

" err operator.

" (err x) compiles into:
"	ldaq	(eval x)
"	tra	ab|err_op,*
"	-- never returns --
"
" err with no args is the same as (err nil)
" err with 2 args cannot be compiled!!

err:	eppap	ap|2			push value of err onto pdl
	staq	ap|-2			for use of lisp_error_$err_op
	enter_pl1_code
	tra	lisp_error_$err_op		go join interpreter's err fcn.

" throw operators.
" these operators execute those cases of the compiled throw
" function that cannot be done in-line.

" throw1 operator.
" takes value to be thrown in aq.  There is no tag.
" called by tra ab|throw1_op,*

throw1:	eppap	ap|4			get room to store value being thrown
	staq	ap|-2
	ldaq	nultag-*,ic		get null tag and fall into throw2 operator





" throw2 operator.
" takes value to be thrown on top of marked pdl,
"  with an empty slot beneath it, tag in aq.
" Called by tra ab|throw2_op,*
" the unmarked pdl is searched for catches using the same
" algorithm as the throw function in the interpreter.  When the catch
" to be thrown to is found, control is transferred to it.  The catch
" has the responsiblity of unwinding the pdl's and resuming execution
" at the point where catch was called.


throw2:
	epplp	ab|system_lp,*
	ldx1	<lisp_static_vars_>|[catch_frame]+1
catch_search:
	tze	bad_throw-*,ic	tra if no more catch frames
	epbplb	ap|0			get pointer to base of marked stack
	lxl6	ab|frame.stack_ptr,x1	get pdl area of catch
	cmpaq	lb|-2,x6			is our tag = tag of catch?
	tze	throw_1-*,ic		yes, win.
	cmpaq	nultag-*,ic		if null tag in throw, any catch will do.
	tze	throw_1-*,ic		so go there.
	lxl2	lb|-2,x6			no, check for nultag
	cmpx2	nulfu,du
	tze	throw_1-*,ic		this is unlabeled catch, it catches us.
	ldx1	ab|frame.prev_frame,x1	not our catch, keep looking.
	tra	catch_search-*,ic

" come here with x1 pointing at catch frame of catch that catches us.

throw_1:	stx1	lisp_static_vars_$catch_frame+1   discard any intervening catches
	enter_pl1_code
	eax2	sp|0			which is the catch.
	cmpx2	ab|frame.ret+3,x1
	tze	throw_to_same_sp-*,ic
"
"	Build arglist to call the Multics unwinder
"	(Started using Multics unwinder 12/6/78 -BSG)
"
	eppbp	ab|frame.ret,x1		Point at label var
	spribp	sp|2
	ldaq	argl_h_of_1
	staq	sp|0
	eppap	sp|0
	short_call unwinder_$unwinder_

	even
argl_h_of_1:
	zero	2,0
	zero	0,04
throw_to_same_sp:

	eppbp	ab|frame.ret,x1*
	spribp	sp|20
	short_return

" come here when an unseen throw tag condition occurrs.

bad_throw:
	eppap	ap|2			place to store bad tag
	staq	ap|-2
	lda	<lisp_error_table_>|[throw_to_no_catch]
	tsx0	Lisp_Error-*,ic
	ldaq	ap|-2			get replacement tag
	eppap	ap|-2
	tra	throw2+1-*,ic		and go try again

	equ	nulfu,Numeric		= type field of nultag

	even
nultag:	zero	0,nulfu		tag used by catch/throw with no tag.
	dec	0			tag is two words....

" Operator to create a string descriptor for PL/I calls
" bb -> place to put descriptor
" aq has the string (or atomic symbol)
" returns with lb the appropriate argument ptr to store
" clobbers regs

create_string_descriptor:
	easplb	0,au		move aq to lb and
	eawplb	1,qu		make it point at first char
	cana	String,dl		check type
	tnz	csd00-*,ic
	cana	Atsym,dl
	tze	csd_barf-*,ic	bad type
	epplb	lb|4		symbol - skip header
csd00:	lda	lb|-1		pick up length
	ora	=o524000,du	set type in desc
	sta	bb|0		store descriptor
	tra	bp|0		return

csd_barf:	epplp	ab|system_lp,*
	lda	<lisp_error_table_>|[csd_op_barf]
	tra	Lisp_Error-*,ic


"
create_varying_string:

" aq contains the symbol or string to initialize it with
" bb -> where to put the descriptor
" word after call contains the declared length of the string
" return with aq containing the new string as a lisp object, and
" return with lb -> the data portion of the string.  due to
" a pl1 crock this points at the chars rather than the length

	eppap	ap|4			save stuff so can cons string
	staq	ap|-2
	eax7	2,x7
	ldq	bp|0			pick up length
	eppbp	bp|1
	spribp	ab|-2,x7
	orq	=o530000,du		make varying string descrip
	stq	bb|0			put in user's descriptor
	anq	-1,dl			clear qu again
	tspbp	ab|cons_string_op,*
	epplb	bb|1		set up return addr of string
	eppbp	ab|-2,x7*
	eax7	-2,x7
	staq	ap|-4			save value we want to return in aq
	ldaq	ap|-2
	easpbb	0,au		copy au to bb
	eawpbb	1,qu
	cana	Atsym,dl
	tze	cvs00-*,ic
	eppbb	bb|4
	tra	cvs01-*,ic

cvs00:	cana	String,dl
	tze	csd_barf-*,ic
cvs01:	lxl2	bb|-1
	sxl2	lb|-1		set current length of varying string
	mlr	(pr,rl),(pr,rl)
	desc9a	bb|0,x2
	desc9a	lb|0,x2
	ldaq	ap|-4			pick up the string into aq
	eppap	ap|-4			for benefit of caller
	tra	bp|0			done


"
" create an array descriptor for a PL/I call
" bb -> the place to put it.  Sufficient words must have been allocated
" aq contains the array (as an array-ptr or a symbol)
" word following the call has type in left half, ndims in right half
" returns with lb -> the data
" clobbers regs

create_array_descriptor:
	easplb	0,au		move aq into lb
	eawplb	0,qu
	cana	Array,dl		got array-ptr?
	tze	cadget-*,ic	no, go get one
cad00:	lxl0	bp|0		get number of dimensions
	cmpx0	lb|array_info.ndims	check it
	tnz	cad_barf-*,ic
	ldx1	lb|array_info.type	check type of array
	cmpx1	bp|0
	tnz	cad_barf-*,ic
	eaa	0,x0		put ndims in descriptor
	als	6
	ora	type_table,x1	and type bits
	sta	bb|0		stor first descriptor word

	eax1	0		the array descriptor is stored backwards!
	epplb	lb|array_data_ptr,*
cad01:	eax1	-2,x1		scan lisp dope vector backwards
	stz	bb|1		lower bound
	ldq	lb|0,x1		upper bound
	sbq	1,dl
	stq	bb|2
	ldq	lb|1,x1		multiplier
	stq	bb|3
	eppbb	bb|3		advance to next dimension
	eax0	-1,x0		count dimensions
	tnz	cad01-*,ic
	tra	bp|1		done, return

" do a get

cadget:	cana	Atsym,dl		better be a symbol
	tze	cad_barf-*,ic
	eppsb	ab|system_lp,*
	link	array_atom,<lisp_static_vars_>|[array_atom]
	ldaq	sb|array_atom,*
	epbpsb	sp|0
cadget0:	lxl0	lb|2		check for end
	canx0	lisp_ptr.type,du
	tnz	cad_barf-*,ic	reached end - no array property
	epplb	lb|2,*		-> next plist cell
	cmpaq	lb|0		array property?
	tze	cadget1-*,ic	yes -use it
	epplb	lb|2,*		no - take next property
	tra	cadget0-*,ic

cadget1:	epplb	lb|2,*		-> plist value
	epplb	lb|0,*		get the array pointer
	tra	cad00-*,ic	and resume normal operation

cad_barf:	epplp	ab|system_lp,*
	lda	<lisp_error_table_>|[cad_op_barf]
	tra	Lisp_Error-*,ic

type_table:
	oct	410000000107	Sexpr
	oct	410000000107	Sexpr
	oct	404000000043	fixnum
	oct	414000000033	flonum


"
" PL/I call operator
" bb -> arg list
" a contains argcount*2 in left half
" bp is return address
" instruction following tspbp is callsp indirect through link.
" At first I had this an epplb that was xec'ed,
" but the crufty hardware then goes to the wrong segment if it is bound

pl1_call_operator:
	eax7	4,x7		save caller's lp and address
	stcd	ab|-4,x7		save ingenious internal return pt
	tra	pl1_call_common
	exit_pl1_code	pop
pl1_call_ret_common:
	lprpbp	ab|-1,x7
	lprplp	ab|-2,x7
	eax7	-4,x7
	tra	bp|1		return skipping callsp inst

pl1_call_nopop:
	eax7	4,x7
	stcd	ab|-4,x7
	tra	pl1_call_common
	exit_pl1_code "nopop
	tra	pl1_call_ret_common

rcv_char_star:
	ldq	bb|0		get length from lisp string
	mlr	(pr,rl),(pr,rl)	move from bp to bb
	desc9a	lb|0,ql
	desc9a	bb|1,ql		body of lisp code
	"			Now pop PL/I stack
	epbpsb	sp|0
	epplb	sp|0
	even
	inhibit	on
	eppsp	sp|stack_frame.prev_sp,*
	sprilb	sb|stack_header.stack_end_ptr
	inhibit	off
	tra	bp|0

pl1_call_common:
	eaq	0,au		set descriptor counter
	ora	4,dl		and arglist type
	staq	bb|0		and finish arg list
	sprplp	ab|-2,x7
	sprpbp	ab|-1,x7

	enter_pl1_code	push,64 "for pl1 vars
	eppap	bb|0		make the call

	eppbp	lisp_static_vars_$unmkd_ptr,*	get back return address
	lprpbp	bp|-1
	epaq	bp|0		get caller's linkage
	lprplp	sb|stack_header.lot_ptr,*au
	stcd	sp|stack_frame.return_ptr
	callsp	bp|0		call to caller's callsp
				" can't use short_call, clobbers pr4
	epplp	sp|stack_frame.lp_ptr,*
	eppbp	lisp_static_vars_$unmkd_ptr,*
	rtcd	bp|-4

"
"
"	Unwind Protect Feature
"	Greenberg, 9/10/78
"

"Called as follows:
"	tspbp	ab|unwp1,*
"	 tra	cleanup_handler
"	code......


unwind_protect:
	eax7	6,7		Push unmarked frame
	eax1	-6,7		Get pointer to it.
	sprilp	ab|frame.ret+2,1	Save LP for both us and handler.
	epplp	ab|system_lp,*
	ldx6	lisp_static_vars_$unwp_frame+1 Get thread.
	stx6	ab|frame.prev_frame,1
	eax6	ap|0		Save marked pdl.
	sxl6	ab|frame.stack_ptr,1
	stc1	ab|frame.dat1,1	Let interpreter know we are compiled.
	spribp	ab|frame.ret,1	Fake lisp PL/I environment closure.
	stx1	lisp_static_vars_$unwp_frame+1 Now we're official.
	epplp	ab|frame.ret+2,1*	Restore his Lisp LP.
	tra	bp|1		Execute protected code.

"Un-unwind-protect operator.  Assumes top unwp frame is the right one.
"Called as:
"	tspbp	ab|ununwp,*


unwind_protect_end:
	epplb	lp|0		Save his Lisp LP
	epplp	ab|system_lp,*
	ldx1	lisp_static_vars_$unwp_frame+1
	ldx6	ab|frame.prev_frame,1 Get last frame, this MUST be unm top.
	stx6	lisp_static_vars_$unwp_frame+1
	ldq	lisp_static_vars_$masked Save interrupt state
	lca	1,dl		Mask all interrupts
	sta	lisp_static_vars_$masked
	epplp	ab|frame.ret+2,1*	Get Handler's Lisp LP.
	eppbb	ab|frame.ret,1*	BB = handler address
	eax7	6,1		Pop unwp frame, set ret block, intsav
	spribp	ab|his_bp-2,7	Save return address.
	sprilb	ab|his_lp-2,7	Save his LP, too.
	stq	ab|-2,7		Store the interrupt system state.
	tra	bb|0		Go execute the handler.


"This next guy is called by the end of interrupt-inhibited handlers.
" As:
"	tspbp	ab|irest_return_op,*

irest_return:
	epplp	ab|system_lp,*	Restore linkage
	ldq	ab|-2,7		Get old interrupt state
	eax7	-2,7		Get PDL back.
	stq	lisp_static_vars_$masked
	szn	lisp_static_vars_$deferred_interrupt Any?
	tze	return		Finish normal return

	enter_pl1_code	push
	eppap	null_argl
	short_call lisp_fault_handler_$interrupt_poll
	exit_pl1_code	pop
	tra	return


"This next character is called by lisp_prog_fns_, to accomplish quite
"the same when the interpreter unwinds an unwp frame.  We are coming
"from the PL/I environment, and we must pop the unm frame as well.

	segdef	xec_unwprot_compiled_handler
xec_unwprot_compiled_handler:
	getlp
	exit_pl1_code
	tspbp	unwind_protect_end	Hah, hah hah.
	enter_pl1_code
	short_return

	end




		    lisp_property_fns_.alm          11/05/86  1612.7r w 11/04/86  1039.2       74331



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
"	lisp_property_fns_ -- those primitives used by lisp programs
"			  to manipulate property lists.
"			   Also handles lists which are structured as
"			   property lists, even if not associated with atoms.
"

get_plist:	" this routine sets bp to point at the plist of something.
		" call by tsx0, following word has pdl cell number in du
		" skip returns if this thing has a plist, else doesn't skip.
		" caller may signal an error if he wants.
		" NOTE:  this perhaps should be changed to try a user
		" interrupt if the thing does not have a plist, or otherwise
		" be user-replaceable so that numbers and lists can have
		" properties associated with them in some strange way.

	ldx1	0,x0		" pick up pdl cell number of arg
	ldaq	ap|0,x1		" get thing whose plist is needed
	cmpaq	ab|nil
	tze	get_plist_of_nil-*,ic
	cana	Unevalable,dl	" have a plist?
	tnz	1,x0		" no, non_skip return
	eppbp	ap|0,x1*		" yes, bp|2 contains it
	tra	2,x0		" and skip return

get_plist_of_nil:
	eppbp	<lisp_static_vars_>|[property_list_of_nil]-2	" bp|2 contains plist
	tra	2,x0



	segdef	get_
get_:	tsx0	get_plist-*,ic	" get the property list of first argument
	arg	-4
	tra	retrn_nil-*,ic	" if has no plist, don't err, just return nil

get_loop:	ldaq	bp|2		" see if there is any more property list left.
	cmpaq	ab|nil
	tze	retrn_aq-*,ic	" if not, return nil.
	eppbp	bp|2,*		" get next indicator cell.
	ldaq	bp|0		" load the indicator.
	eppbp	bp|2,*		" and get pointer to value cell for that indicator.
	cmpaq	ap|-2		" see if desired indicator.
	tnz	get_loop-*,ic	" if not, try next indicator on list.
	ldaq	bp|0		" load value to return.
retrn_aq:	eppap	ap|-4		" pop off two args
retrn:	epplp	ab|-4,x7*
	eppbp	ab|-2,x7*
	eax7	-4,x7		" pop off save stuff.
	tra	bp|0		" return.

retrn_nil: ldaq	ab|nil		" any atom not having a pname has null property list.
	tra	retrn_aq-*,ic	" so return nil...this used to be error.

	segdef	getl_
getl_:	ldaq	ap|-2
	cana	Atomic,dl			" make sure it is a list.
	tze	getl_ok-*,ic
	cmpaq	ab|nil			" nil is ok too.
	tze	getl_ok-*,ic
	lcq	-fn_getl,dl
	tsx6	error2-*,ic		" error in second of two args.
	tra	getl_-*,ic

getl_ok:	tsx0	get_plist-*,ic		" find atom whose property is to be gotten
	arg	-4
	tra	retrn_nil-*,ic		" no properties -> nil
getl_lp:	ldaq	bp|2			" check to see if any properties
	cmpaq	ab|nil			" left...if not return nil
	tze	retrn_aq-*,ic
	staq	ap|-4			" save as a possible return val
	eppbp	bp|2,*

	epplp	ap|-4			" see if cur indicator is member of list.
getl_lp1:	ldaq	lp|2			" see if any more tings in list
	cmpaq	ab|nil
	tze	getl_next-*,ic
	epplp	lp|2,*			" if so, check next element
	ldaq	lp|0			" against current indicator
	cmpaq	bp|0
	tnz	getl_lp1-*,ic		" if not eq, then try next element.

	ldaq	ap|-4			" load saved result.
	tra	retrn_aq-*,ic

getl_next:eppbp	bp|2,*			" get next property cell pointer.
	tra	getl_lp-*,ic

	segdef	plist_			" function to get the plist
plist_:	tsx0	get_plist-*,ic
	arg	-2
	eppbp	ab|nil-2			" if doesn't have one, for now use nil
	ldaq	bp|2			" pick up the plist
	eppap	ap|-2
	tra	retrn-*,ic

	segdef	setplist_			" function to set a new plist
setplist_:tsx0	get_plist-*,ic
	arg	-4
	tra	cant_set_plist-*,ic		" error to set plist of e.g. number.
	ldaq	ap|-2			" get plist to set
	staq	bp|2			" store it away
	ldaq	ap|-4			" return first arg
	tra	retrn_aq-*,ic

cant_set_plist:
	lda	<lisp_error_table_>|[cant_set_plist]
	eax0	-4			" ap|-4 has the bad thing
	tsx6	error00-*,ic		" go signal error
	tra	setplist_-*,ic		" then try again

	segdef	remprop_
remprop_loses:
	lcq	-fn_remprop,dl		" load error code
	tsx6	error1-*,ic		" go complain to user
					" and if reparations made, try again.

remprop_:	tsx0	get_plist-*,ic		" get plist of first arg
	arg	-4
	tra	remprop_loses-*,ic		" can't get it, complain
	epplp	bp|0			" lp will point at cell to rplacd
rem_loop:	ldaq	lp|2			" check for end of plist.
	cmpaq	ab|nil
	tze	retrn_aq-*,ic		" if end, return nil.
	eppbp	lp|2,*			" get pointer at property indicator cell.
	ldaq	bp|0			" load the indicator
	cmpaq	ap|-2			" cand see if the desired one.
	tze	rem_property-*,ic		" if so remove the property.
	epplp	bp|2,*			" look at next element
	tra	rem_loop-*,ic		" and try again.

rem_property:
	eppbp	bp|2,*			" get pointer to second cell deleted.
	ldaq	bp|2			" and rplacd its cdr into place
	staq	lp|2			" pointed at by lp.
	spribp	ap|-2			" result is second cell
	ldaq	ap|-2			" return indicator of success.
	tra	retrn_aq-*,ic

	segdef	putprop_
putprop_loses:
	lcq	-fn_putprop,dl	" load our name
	tsx6	error3-*,ic	" and call the error routine

putprop_:	tsx0	get_plist-*,ic	" find plist of arg 1
	arg	-6
	tra	putprop_loses-*,ic	" if has none, barf

	epplb	bp|0		" save address of start of plist
put_loop:	ldaq	bp|2		" check to see if at end of plist.
	cmpaq	ab|nil
	tze	make_new_cells-*,ic	" if so, must make addition to plist at front.
	eppbp	bp|2,*		" get pointer at indicator cell
	ldaq	bp|0		" load indicator.
	eppbp	bp|2,*		" get value cell pointer into bp
	cmpaq	ap|-2		" if indicator eq to arg 3, rplacd
	tnz	put_loop-*,ic	" oterwise jump down list to next indicator.
	ldaq	ap|-4		" get new value to rplaca
	staq	bp|0		" and do it.
	eppap	ap|-6		" get rid of args...value to return is in aq
	tra	retrn-*,ic

make_new_cells:			" code to make two new list cells and splice tem in.
	eppap	ap|6		" get arg list room
	ldaq	lb|2		" load old cdr of arg 1
	staq	ap|-2		" and set up call to cons.
	ldaq	ap|-4-6		" load arg 2
	staq	ap|-4
	eax7	8,x7		" get room for two type 1 calls to cons.
	sprilp	ab|-8,x7
	sprilp	ab|-4,x7
	stcd	ab|-2,x7		" save return address.
	tra	<lisp_alloc_>|[cons_]
	staq	ap|-2
	stcd	ab|-2,x7		" call cons again to add indicator.
	tra 	<lisp_alloc_>|[cons_]
	staq	ap|-2		" save new property list
	tsx0	get_plist-*,ic	" get where to put it
	arg	-4
	drl	0		" I don't know what to do here
	ldaq	ap|-2		" get back result of consing
	staq	bp|2		" store new property list
	eppbp	bp|2,*
	ldaq	bp|2,*		" load the value for return
	tra	retrn_aq-*,ic


"	The PL/I callable entries are here...

	entry	get,putprop,getl,remprop

get:	tsx6	pl1_to_lisp-*,ic
	tra	get_-*,ic
putprop:	tsx6	pl1_to_lisp-*,ic
	tra	putprop_-*,ic
getl:	tsx6	pl1_to_lisp-*,ic
	tra	getl_-*,ic
remprop:	tsx6	pl1_to_lisp-*,ic
	tra	remprop_-*,ic

pl1_to_lisp:
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	eax7	4,x7
	sprilp	ab|-4,x7		" save lp and return address.
	stcd	ab|-2,x7
	tra	0,x6		" and call the lisp routine.
	eppap	ap|2		" now put result back on stack.
	staq	ap|-2
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	short_return


error1:	eax0	-4		" offset of losing arg from stack top.
error:	lda	<lisp_error_table_>|[bad_arg_correctable]
error00:	eax7	4,x7		" save regs, error data on unmkd stack
	staq	ab|-2,x7
	eppap	ap|2		" get losing arg on stack top.
	ldaq	ap|-2,x0
	staq	ap|-2
	stx6	ab|-4,x7		" save return address
	stx0	ab|-3,x7		" and stack offset of bad arg.
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	push
	eppap	noargs-*,ic
	short_call <lisp_error_>|[lisp_error_]
	eaa	sp|16,*		" get back pointer from stack frame
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au		" and pop off stack frame.
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	ldaq	ap|-2		"load returnd value.
	eppap	ap|-2
	ldx0	ab|-1,x7
	ldx6	ab|-2,x7
	staq	ap|0,x0		" put value back in correct place.
	eax7	-2,x7		" pop off saved index reg block.
	tra	0,x6		" return to try again.
error2:	eax0	-2		" offset of losing arg.
	tra	error-*,ic
error3:	eax0	-6	" offset of losing arg.
	tra	error-*,ic

	even
noargs:	oct	4,0		" null arg list.
	include 	stack_header
	include 	lisp_object_types
	include	lisp_name_codes
	include	lisp_stack_seg
	end




		    lisp_quick_fcns_.alm            11/05/86  1612.7r w 11/04/86  1039.2      257148



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
"	Procedure lisp_quick_fcns_, which contains those functions which
"	are optimally hand-coded for maximum interpreter speed.
"
"	DPR 14 August 72
"

	tempd	arg(2)
	include	stack_header
	include 	lisp_object_types
	include 	lisp_stack_seg
	include 	lisp_error_codes
	include	lisp_name_codes

	even			some constants for numeric routines
fixnum_zero:
	vfd	36/fixnum_type
	dec	0
flonum_zero:
	vfd	36/flonum_type
	dec	0.0		good old floating point.

float_q:	llr	36		convert to fixed double word.
	lrs	36		extend sign.
	lde	=71b25,du		load exponent with magic number
	fad	=0.0,du		and normalize
	tra	0,x6		return

"	common code to return from a procedure which pushed its return address on
"	the unmkd pdl.

popj:	eppbp	ab|-2,x7*		reload bp from unmarked pdl
	eax7	-2,x7		pop off pdl
	tra	bp|0		and return

"	standard return sequence for type 1 lisp subr. Such subrs
"	have the caller's lp and the return address pushed on the unmkd
"	pdl.

retrn1:	eppbp	ab|-2,x7*		reload return address
	epplp	ab|-4,x7*		and caller's lp
	eax7	-4,x7		pop unmarked stack
	tra	bp|0		and return to caller.
"
	segdef	null
null:	ldaq	ap|-2		load argument
	eppap	ap|-2		pop stack
	cmpaq	ab|nil		see if arg is nil
	tze	ret_t-*,ic	if so, return true.
ret_nil:	ldaq	ab|nil		else return false.
	tra	bp|0
ret_t:	ldaq	ab|true
	tra	bp|0

	segdef	eq
eq:	ldaq	ap|-4
	cmpaq	ap|-2		compare 2 arguments as pointers.
	eppap	ap|-4		pop stack, changing no indicators.
	tze	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	atom
atom:	lda	ap|-2		load type field
	eppap	ap|-2		and pop off stack
	cana	Atomic,dl
	tze	ret_nil-*,ic
	tra	ret_t-*,ic

	segdef	numberp
numberp:	ldaq	ap|-2
	eppap	ap|-2
	cana	Numeric,dl
	tze	ret_nil-*,ic
	tra	ret_t-*,ic

	segdef	fixp
fixp:	ldaq	ap|-2
	eppap	ap|-2
	cana	Fixed+Big_fixed,dl
	tnz	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	smallnump
smallnump:ldaq	ap|-2
	eppap	ap|-2
	cmpa	fixnum_type,dl	" only small fixnums match here.
	tze	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	bigp
bigp:	ldaq	ap|-2
	eppap	ap|-2
	cana	Big_fixed,dl
	tnz 	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	floatp
floatp:	ldaq	ap|-2
	eppap	ap|-2
	cmpa	flonum_type,dl
	tze	bp|0
	tra	ret_nil-*,ic

	segdef	stringp
stringp:	ldaq	ap|-2
	eppap	ap|-2
	cana	String,dl
	tnz	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	subrp
subrp:	lda	ap|-2
	eppap	ap|-2
	cana	Subr,dl
	tnz	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	symbolp
symbolp:	lda	ap|-2
	eppap	ap|-2
	cana	Atsym,dl
	tnz	ret_t
	tra	ret_nil

	segdef	arrayp
arrayp:	lda	ap|-2
	eppap	ap|-2
	cana	Array,dl
	tnz	ret_t
	tra	ret_nil

	segdef	filep
filep:	lda	ap|-2
	eppap	ap|-2
	cana	File,dl
	tnz	ret_t
	tra	ret_nil

	segdef	zerop
zerop:	ldaq	ap|-2
	cana	Fixed+Float+Big_fixed,dl
	tnz	5,ic
	tsx4	push_ptrs
zerop_tsx4:
	tsx4	bad_arg
	tsx4	pop_ptrs
	tra	zerop
	eppap	ap|-2		pop stack.
	cmpaq	fixnum_zero-*,ic	see if fixed zero.
	tze	ret_t-*,ic
	cmpaq	flonum_zero-*,ic	see if float zero
	tze	ret_t-*,ic
	tra	ret_nil-*,ic

	segdef	oddp		" determine if fixnum is odd.
oddp:	ldaq	ap|-2		" check arg for fixnum
	cana	Big_fixed,dl	" big case, must check least significant word.
	tze	not_big-*,ic
	ldaq	ap|-2,*		" load first two words of bignum.
oddp_test:eppap	ap|-2
	canq	1,dl		" least significant word is in q.
	tze	ret_nil-*,ic
	tra	ret_t-*,ic

not_big:	cmpa	fixnum_type,dl	" must be fixnum arg.
	tze	oddp_test-*,ic

	tsx4	push_ptrs
oddp_tsx4:tsx4	bad_arg
	tsx4	pop_ptrs
	tra	oddp-*,ic		" and try again.

push_ptrs:	eax7	4,x7
	sprilp	ab|-4,x7
	spribp	ab|-2,x7
	epplp	ab|system_lp,*	" get system lp.
	tra	0,x4		return
pop_ptrs:	epplp	ab|-4,x7*		" reload lp
	eppbp	ab|-2,x7*
	eax7	-4,x7		" and pop stack.
	staq	ap|-2		" put new value back
	tra	0,x4
"
	segdef	runtime
runtime:	eax7	6,x7
	sprilp	ab|-6,x7
	spribp	ab|-4,x7
	epplp	ab|system_lp,*	" get sytem lp, to save data for pl1.
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code

	push			" get pl1 stack frame.
	eppbp	<lisp_static_vars_>|[unmkd_ptr],*
	eppbp	bp|-2		" get place to put cpu time.
	spribp	arg+2
	ldaq	one_arg-*,ic
	staq	arg
	eppap	arg
	short_call <hcs_>|[virtual_cpu_time_]
	eppbp	sp|16,*		" pop stack frame off.
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	bp|0

	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	ldq	ab|-1,x7		" get cpu time.
	lda	fixnum_type,dl
	eppbp	ab|-4,x7*
	epplp	ab|-6,x7*
	eax7	-6,x7
	tra	bp|0		" return





"

"	fsubrs for comment and declare.

	segdef	comment
comment:	ldaq	<lisp_static_vars_>|[comment_atom]
	eppap	ap|-2
	tra	retrn1-*,ic

	segdef	declare
declare:	ldaq	<lisp_static_vars_>|[declare_atom]
	eppap	ap|-2
	tra	retrn1-*,ic
"
	segdef	length		computes length of list.
length:	ldaq	fixnum_zero-*,ic	initial length is zero.
	eax7	2,x7		save return address.
	spribp	ab|-2,x7
	eppbp	ap|-4		start list off right.
len_loop:	lxl0	bp|2		see if any more
	canx0	Atomic,du
	tnz	ret_l-*,ic	if none, return aq
	adq	1,dl		bump aq
	eppbp	bp|2,*		go down cdr
	tra	len_loop-*,ic	and try again.
ret_l:	eppap	ap|-2		pop arg off stack
	tra	popj-*,ic		and return to address saved on pdl

	segdef	last
last:	ldaq	ap|-2		result is arg if atomic
	eax7	2,x7
	spribp	ab|-2,x7		save return addr
	eppbp	ap|-4		start list off right
last_loop:lxl0	bp|2		get type of cdr
	canx0	Atomic,du		see if atom,
	tnz	ret_l-*,ic	return aq if so.
	ldaq	bp|2		else load cdr into aq
	eppbp	bp|2,*		and chase down list
	tra	last_loop-*,ic

"
"	lisp function _e_q_u_a_l.
"
"	Other routines in this segment require that equal not change index register
"	3 during its operation, as it is used as an internal procedure by some.
"
	segdef	equal
equal:	eax7	2,x7		get space and
	spribp	ab|-2,x7		save return address.
	eax0	0		set recursion depth.

eql_lp:	ldaq	ap|-4		first test for eq
	cmpaq	ap|-2
	tze	ret_t_eql-*,ic	and return true for this level if so.
	cana	Atomic,dl		check for list
	tze	list_eql-*,ic	and go to recursive equal
	cana	Atsym+Subr+Fixed+Float,dl	these are equal iff eq.
	tnz	ret_nil_eql-*,ic
	cana	Big_fixed,dl	check for bignum
	tnz	bignum_eql-*,ic
	cana	String,dl		check for string
	tze	ret_nil_eql-*,ic	and if not, unknown type.

" 				string compare....
	lda	ap|-2		load type field
	cana	String,dl
	tze	ret_nil_eql-*,ic
	lda	ap|-2,*		load length
	cmpa	ap|-4,*		and compare lengths.
	tnz	ret_nil_eql-*,ic	if not equal, then complain.
	eppbp	ap|-2,*		get ptrs to strings
	epplb	ap|-4,*
	cmpc	(pr,rl),(pr,rl)
	desc9a	bp|1,al
	desc9a	lb|1,al
	tze	ret_t_eql-*,ic
	tra	ret_nil_eql-*,ic

list_eql:	lda	ap|-2		load type of second arg
	cana	Atomic,dl		if atomic, then can't be a list
	tnz	ret_nil_eql-*,ic
	eppap	ap|4		get room to recurse
	eax0	-4,x0		and bump recursion counter.
	eppbp	ap|-8,*		get car and cdr of arg 1
	ldaq	bp|0
	staq	ap|-4		and pass to loop
	ldaq	bp|2
	staq	ap|-8
	eppbp	ap|-6,*		get car and cdr of 2nd arg
	ldaq	bp|0
	staq	ap|-2
	ldaq	bp|2
	staq	ap|-6
	tra	eql_lp-*,ic

bignum_eql:			" first arg is bignum...
	lda	ap|-2		load second arg type.
	cana	Big_fixed,dl
	tze	ret_nil_eql-*,ic

	eppbp	ap|-4,*		get pointer to first bignum
	ldq	bp|0		sign and length in q
	epplb	ap|-2,*
	cmpq	lb|0		compare sign and length with other value.
	tnz	ret_nil_eql-*,ic	if sign or length differ, return nil
	eaq	1,ql		get total length in qu and flush sign bits
	qls	2		convert to characters
	cmpc	(pr,rl),(pr,rl)
	desc9a	bp|0,qu
	desc9a	lb|0,qu
	tze	ret_t_eql-*,ic
"	tra	ret_nil_eql-*,ic

ret_nil_eql:			" return nil, which propagates back...
	ldaq	ab|nil
	eppap	ap|-4,x0		and pop back all of stack stuff
	tra	popj-*,ic

ret_t_eql:eax0	4,x0		pop off recursion counter
	tze	2,ic		this and next could be replaced by one inst.
	tpl	ret_t_for_real-*,ic
	eppap	ap|-4		pop off stack
	tra	eql_lp-*,ic	and return, checking cdr.
ret_t_for_real:
	eppap	ap|-8,x0		pop stack
	ldaq	ab|true
	tra	popj-*,ic



	segdef	alphalessp
alphalessp:
	tsx6	stringcmp
	tra	true_return
	tra	nil_return
	tra	nil_return

	segdef	samepnamep
samepnamep:
	tsx6	stringcmp
	tra	nil_return
	tra	true_return
	tra	nil_return

true_return:
	ldaq	ab|true
	tra	2,ic
nil_return:
	ldaq	ab|nil
	eppap	ap|-4
	tra	retrn1

stringcmp:
	ldaq	ap|-4		"  load  first arg.
	cana	Atsym+String,dl
	tnz	good_alpha1	" ok argument is string or atsym
	tsx4	bad_string
	staq	ap|-4
	tra	stringcmp

good_alpha1:
	ldaq	ap|-2
	cana	Atsym+String,dl	" check for  string or atsym.
	tnz	good_alpha2
	tsx4	bad_string
	staq	ap|-2
	tra	good_alpha1

good_alpha2:
	epplb	ap|-2,*	" get pointer to second arg.
	cana	String,dl		" if string, ptr is right.
	tnz	2,ic
	epplb	lb|4		" otherwise bump pointer.
	eppbp	ap|-4,*		" get pointer to first arg's ascii in bp
	lda	ap|-4
	cana	String,dl		" check for string.
	tnz	2,ic
	eppbp	bp|4		" otherwise bump bp to point at pname.

	lda	bp|0
	cmpa	lb|0		" get minimum length of args.
	tmi	2,ic
	lda	lb|0
	cmpc	(pr,rl),(pr,rl)
	desc9a	bp|1,al
	desc9a	lb|1,al
	tnc	0,x6		first < second
	tnz	2,x6		first > second

	" appear equal, check lengths

	lda	bp|0
	cmpa	lb|0
	tmi	0,x6		second longer, it is >
	tze	1,x6		same length, they are =
	tra	2,x6		first longer, it is >

bad_string:
	eppap	ap|2
	staq	ap|-2		" save losing arg.
	eax7	4,x7		" save useful index regs.
	stx6	ab|-3,x7
	stx4	ab|-4,x7
	cmpx6	alphalessp+1,du	" see which function we are.
	tnz	3,ic
	lcq	-fn_alphalessp,dl
	tra	got_name		" jump into error code.
	lcq	-fn_samepnamep,dl
	tra	got_name

	segdef	getcharn
getcharn:	tsx6	2,ic		same as getchar but returns a fixnum

	segdef	getchar		" routine to get nth char of pname atom or string.
getchar:	eax6	0		set esw

" getchar and getcharn join here.  x6 is nonzero for getcharn

	ldaq	ap|-4		" validate arguments.
	cana	Atsym+String,dl	" may be pname atom or string.
	tnz	good_getch1
getch_tsx4:tsx4	bad_arg		" bad first arg...
	staq	ap|-4
	tra	getchar+1		" retry with new value.

good_getch1:			" validate second argument...must be fixnum.
	ldaq	ap|-2		" second arg.
	cmpa	fixnum_type,dl	" must compare exactly.
	tze	good_getch2
getch_tsx4_2:
	tsx4	bad_arg
	staq	ap|-2
	tra	good_getch1	" retry with new value.

good_getch2:			" now do the operation.
	eppbp	ap|-4,*		" get pointer to string or atsym.
	lda	ap|-4
	cana	Atsym,dl		" if atsym, move pointer to point to name.
	tze	2,ic
	eppbp	bp|4		" name is 4 offset from beginning.

	sbq	1,dl		" q register still contains second argument.
	tmi	ret_nil_getch	" if <= 0 then return nil...out of range.
	cmpq	bp|0		" if > than number of chars in name,
	tpl	ret_nil_getch	" return nil for out of range.
	a9bd	bp|1,ql		bp -> char.  necc. because what length to put in mrl?
	mrl	(pr),(pr),fill(0)	unpack the character into a fixnum
	desc9a	bp|0,1
	desc9a	ap|-1,4
	ldaq	ap|-2		pick up result, fixnum type already set from arg
	eax6	0,x6
	tnz	getcharn_return-*,ic
	staq	ap|-4		make arg to call ascii with.
	eppap	ap|-2		and pop off other arg.
	tra	<lisp_reader_alm_>|[ascii_alm]

ret_nil_getch:
	ldaq	ab|nil		" return nil for out of bounds arguments.
	eax6	0,x6
	tze	2,ic
	 ldaq	 fixnum_zero-*,ic
getcharn_return:
	eppap	ap|-4
	tra	retrn1		" return as type 1 subr.

	segdef	prog1		"10/8/80 -BSG
prog1:	ldaq	ap|0,x5
	eppap	ap|0,x5
	tra	bp|0

	segdef	prog2
prog2:	ldaq	ap|2,x5		x5 contains -2*number of arguments.
	eppap	ap|0,x5
	tra	bp|0

	segdef	progn
progn:	ldaq	ap|-2
	eppap	ap|0,x5
	tra	bp|0

"
	segdef	and
and:	ldaq	ab|true		preload for no arguments.
and_loop:	lxl0	ap|-2
	canx0	Atomic,du		test type of remaining frag of arg list.
	tnz	and_done-*,ic
	eppap	ap|2		get space for eval argument.
	eppbp	ap|-4,*
	ldaq	bp|0
	staq	ap|-2
	ldaq	bp|2
	staq	ap|-4
	eax7	4,x7		now call eval...
	eax5	-2		1 argument.
	sprilp	ab|-4,x7
	stcd	ab|-2,x7		save return address.
	tra	<lisp_>|[eval_]	KLUDGE. requires that eval_ be bound in with this proc.
	cmpaq	ab|nil		check return val.
	tnz	and_loop-*,ic	if nil, then we are done.
and_done:	eppap	ap|-2		pop off rest of stuff on stack.
	tra	retrn1-*,ic	return to caller

	segdef	or
or:	ldaq	ab|nil		preload or of no arguments.
or_loop:	lxl0	ap|-2		check for atom at end of list.
	canx0	Atomic,du
	tnz	and_done-*,ic
	eppap	ap|2
	eppbp	ap|-4,*
	ldaq	bp|0
	staq	ap|-2
	ldaq	bp|2
	staq	ap|-4		and call eval now.
	eax7	4,x7
	eax5	-2		1 argument
	sprilp	ab|-4,x7
	stcd	ab|-2,x7
	tra	<lisp_>|[eval_]	KLUDGE. (see and)
	cmpaq	ab|nil
	tze	or_loop-*,ic
	tra	and_done-*,ic

"
	segdef	cond		" lisp conditional function.
cond:	eppap	ap|4		get room for temps.
	ldaq	ab|nil
	staq	ap|-2
cond_loop:lda	ap|-6		load type of cond list
	cana	Atomic,dl		and check for end of list.
	tnz	cond_done-*,ic
	eppbp	ap|-6,*		get head of list
	ldaq	bp|0
	staq	ap|-4		and store it as the next phrase.
	ldaq	bp|2		get cdr of cond list
	staq	ap|-6		and save for next time.
	ldaq	ap|-4,*		get predicate.
	staq	ap|-2		and set it to be arg to eval
	eax7	4,x7
	eax5	-2		1 argument
	sprilp	ab|-4,x7		set up call to eval...
	stcd	ab|-2,x7
	tra	<lisp_>|[eval_]	KLUDGE, requiring that cond be bound with eval.
	eppap	ap|2		save result on stack
	staq	ap|-2
	cmpaq	ab|nil
	tze	cond_loop-*,ic	loop back for next predicate.
cond_ev:	eppbp	ap|-4,*		get phrase
	ldaq	bp|2		load cdr of phrase
	cana	Atomic,dl		check for end
	tnz	cond_done-*,ic
	staq	ap|-4		and store as rest of phrase
	ldaq	ap|-4,*		load car of phrase
	staq	ap|-2		and store as next thing.
	eax7	4,x7
	eax5	-2		1 argument.
	sprilp	ab|-4,x7		save stuff for call to eval
	stcd	ab|-2,x7
	tra	<lisp_>|[eval_]	KLUDGE.
	eppap	ap|2
	staq	ap|-2		save result
	tra	cond_ev-*,ic
cond_done:ldaq	ap|-2		load last result
	eppap	ap|-6		pop off stacks
	tra	retrn1-*,ic	and go to return sequence.
"

	segdef	member
member:	lda	ap|-4		if first arg atomic, turn into memq
	cana	Atsym+Subr+Fixed+Float,dl	(see equal)
	tnz	memq-*,ic
	eax7	2,x7		save return address
	spribp	ab|-2,x7
	lda	ap|-2		load type of 2nd arg.
memb_lp:	cana	Atomic,dl		see if end of list.
	tnz	ret_mq-*,ic
	eppap	ap|4		get room for args to equal.
	ldaq	ap|-8		load our first arg.
	staq	ap|-4		and make it first equal arg.
	ldaq	ap|-6,*		get car of list remaining of 2nd arg
	staq	ap|-2		and save it as secind equal arg.
	tspbp	equal-*,ic	equal is a fast call subr.
	cmpaq	ab|nil		check result,
	tnz	ret_mq_obj-*,ic	and if truely equal, return list.
	eppbp	ap|-2,*		else take cdr of list,
	ldaq	bp|2
	staq	ap|-2		and make it the current list.
	tra	memb_lp-*,ic	and loop back to try again.

	segdef	memq
memq:	lda	ap|-2		check cdr of list
	eax7	2,x7		get space and
	spribp	ab|-2,x7		save return address.
mq_lp:	cana	Atomic,dl
	tnz	ret_mq-*,ic
	eppbp	ap|-2,*		get car of it
	ldaq	bp|0
	cmpaq	ap|-4		see if eq to first arg
	tze	ret_mq_obj-*,ic	and if so return ap|-2
	ldaq	bp|2
	staq	ap|-2		store cdr of list back
	tra	mq_lp-*,ic
ret_mq:	ldaq	ab|nil
	tra	2,ic		skip to return sequence.
ret_mq_obj:ldaq	ap|-2		load current object list
	eppap	ap|-4		restore stack
	tra	popj-*,ic
"
	segdef	sassoc
sassoc:	eax3	-2		offset to assoc args from ap.
				" NOTE: assumes x3 is not used by equal!
				" do not change equal to use x3 or call out.
	tra	assoc1-*,ic	jump into common code.

	segdef	assoc
assoc:	eax3	0		offset to assoc args from ap, see above
assoc1:	ldaq	ap|-4,x3		pick up arg 1
	cana	Atsym+Subr+Fixed+Float,dl
	tnz	assq1-*,ic	if eq =_ equal, use assq or sassq
	eppap	ap|6		get room for arg list to equal
	eax7	2,x7		and get space to save ret addr
	spribp	ab|-2,x7
	lda	ap|-8,x3		load type of list arg 2
ass_lp:	cana	Atomic,dl
	tnz	ret_ass_nil-*,ic
	ldaq	ap|-8,x3*		load car of arg 2
	cana	Atomic,dl		either it is atom, and should be skipped
	tnz	skip_ass-*,ic	or should look at its car
	staq	ap|-6		and save as possible return value
	ldaq	ap|-6,*		load car of that
	staq	ap|-2		and make arg of call to equal
	ldaq	ap|-10,x3		other arg is our first arg
	staq	ap|-4
	tspbp	equal-*,ic
	cmpaq	ab|nil
	tnz	assq_done-*,ic	if equal, then return value at ap|-2
	eppap	ap|4		get back space lost by equal
skip_ass:
	eppbp	ap|-8,x3*		get cdr of arg 2
	ldaq	bp|2
	staq	ap|-8,x3		and save it
	tra	ass_lp-*,ic
ret_ass_nil:
	eppap	ap|-4		pop some off stack
	tra	ret_assq_nil-*,ic
"
	segdef	sassq
sassq:	eax3	-2		offset of assoc args from ap.
	tra	assq1-*,ic	get into common code.
	segdef	assq
assq:	eax3	0		offset of args from ap
assq1:	eppap	ap|2
	eax7	2,x7
	spribp	ab|-2,x7
	lda	ap|-4,x3
assq_lp:	cana	Atomic,dl		check for end of lsit
	tnz	ret_assq_nil-*,ic
	eppbp	ap|-4,x3*		get car
	ldaq	bp|0
	cana	Atomic,dl
	tnz	skip_assq-*,ic	skip atomic list element
	staq	ap|-2		save list element
	ldaq	ap|-2,*		and get its car
	cmpaq	ap|-6,x3		compare with first arg
	tze	assq_done-*,ic	and if eq, return ap|-2
skip_assq:ldaq	bp|2		get cdr of list
	staq	ap|-4,x3		and save it
	tra	assq_lp-*,ic
assq_done:ldaq	ap|-2		load result
assq_ret:	eppap	ap|-6,x3		restore stack
	tra	popj-*,ic
ret_assq_nil:
	ldaq	ab|nil
	cmpx3	0,du		see which entry we came through.
	tze	assq_ret-*,ic	if assoc or sassoc, just return nil
" 				else want to apply third arg to nil.
	staq	ap|-4,x3		store in second arg position for apply.
	ldaq	ap|-2,x3		get function arg.
	eppap	ap|-2,x3		and bump back the stack.
	staq	ap|-4		save function as first arg to apply
	eax7	2,x7		now set up call to apply.
	ldaq	ab|-4,x7		load our old return address
	staq	ab|-2,x7		and make it apply's return address!
	sprilp	ab|-4,x7		save our caller's lp where apply will reload it
	epplp	ab|system_lp,*	get our lp (which must be apply's also,
				" since we are relying on fact that apply is bound in.)
	eax5	-4		load lsubr arg count.
	tra	<lisp_>|[apply_]	call apply who will return to our caller.
"
	segdef	delete
delete:	ldaq	ap|0,x5		get first argument
	cana	Atsym+Subr+Fixed+Float,dl	eq =_ equal for this?
	tnz	delq-*,ic		yes, turn into delq
	eax3	-1		load number for thing to be deleted as infinity.
	cmpx5	-4,du		check for two args
	tze	3,ic		if so, infinite number of deletions to be done.
	eax0	fn_delete
	tsx6	get_count-*,ic	else go to subroutine get count from third arg.
	eppap	ap|6		get room for args to equal, and temp
	cmpx3	0,du		check for no deletion case.
	tze	ret_del-*,ic
	lda	ap|-8		get second arg
head_loop:cana	Atomic,dl		see if not list, return if not.
	tnz	ret_del-*,ic
	ldaq	ap|-8,*		get car of second arg
	staq	ap|-2		make it arg to equal
	ldaq	ap|-10		get our first arg
	staq	ap|-4		make it equal's first
	tspbp	equal-*,ic
	eppap	ap|4		get back space
	cmpaq	ab|nil
	tze	end_head-*,ic	if not equal, then this phase is done.
	eppbp	ap|-8,*		get pointer to list
	ldaq	bp|2		load cdr
	staq	ap|-8
	eax3	-1,x3		decrement count of deleteions
	tnz	head_loop-*,ic	and go back to try again.
	tra	ret_del-*,ic
end_head:	ldaq	ap|-8
	staq	ap|-6		now we have to look at the cadr caddr ...
del_loop:	cmpx3	0,du		see if no more deletions to be done.
	tze	ret_del-*,ic
del_loop1:eppbp	ap|-6,*		get pointer to list cell whose cadr we are checking.
	lda	bp|2		see if there is a list at the cdr
	cana	Atomic,dl
	tnz	ret_del-*,ic	and if not, returm
	ldaq	bp|2,*		load cadr of list
	staq	ap|-2		and make it second arg to equal
	ldaq	ap|-10		load our first arg,
	staq	ap|-4		and make it equal's first
	tspbp	equal-*,ic
	eppap	ap|4		get back space
	eax2	2		so cdr's can be easily accessed.
	cmpaq	ab|nil		check result of equal call
	tze	no_del-*,ic	if not equal, don't delete
	eppbp	ap|-6,*		reload bp, clobbered by equal call
	ldaq	bp|2,*2		get cddr of list,
	staq	bp|2		and make it the cdr
	eax3	-1,x3		decrement count
	tra	del_loop-*,ic
no_del:	ldaq	ap|-6,*2
	staq	ap|-6		set result to cdr of result.
	tra	del_loop1-*,ic
ret_del:	ldaq	ap|-8
	eppap	ap|-10		back up stack
	tra	retrn1-*,ic

	segdef	delq
delq:	eax3	-1		load infinite deletion count
	cmpx5	-4,du		see if we got more than two args
	tze	3,ic		if not, don't check third arg.
	eax0	fn_delq
	tsx6	get_count-*,ic	get deletion count
	eppbp	ap|-2		bp always points at thing to replace if car eq
				" to deleted object.
	eax2	2		allows cdrs to be easily taken.
dloop:	cmpx3	0,du		see if any more are to be deleted.
	tze	dq_end-*,ic	if no more, return.
dloop1:	lda	bp|0		load type of current list position.
	cana	Atomic,dl		see if we are at end of list.
	tnz	dq_end-*,ic
	ldaq	bp|0,*		load car of list
	cmpaq	ap|-4		see if eq to our first arg
	tnz	no_dq-*,ic	if no deletion to be done go to get cdr
	ldaq	bp|0,*x2		load cdr of list
	staq	bp|0		and make it current list, rplacd'ing in place.
	eax3	-1,x3		decrement deletion counter
	tra	dloop-*,ic	and loop back
no_dq:	eppbp	bp|0,*2		go to cdr of list
	tra	dloop1-*,ic	and loop back
dq_end:	ldaq	ap|-2		load result
	eppap	ap|-4		pop args off stack
	tra	retrn1-*,ic	and return.
"
	segdef	rplaca
rplaca:	ldaq	ap|-4		load first arg
	cana	Atomic,dl		and check for valid rplaca
	tze	replace-*,ic	if list, then go ahead.
rplaca_tsx4:
	tsx4	bad_arg-*,ic	signal error.
	staq	ap|-4		replace argument,
	tra	rplaca-*,ic	and retry.
replace:	ldaq	ap|-2		load replacement
	staq	ap|-4,*		and store in car of list
	ldaq	ap|-4
	eppap	ap|-4		pop back stack
	tra	retrn1-*,ic	rplaca is type one subr.

	segdef	rplacd
rplacd:	eax2	2		we are to replace cdr. (no checking is done either)
	ldaq	ap|-2		load replacement
	staq	ap|-4,*x2		and zap it into cons.
	ldaq	ap|-4		load result
	eppap	ap|-4		pop stack,
	tra	bp|0		and return.

	segdef	displace
displace:	lda	ap|-4		load first argument
	cana	Atomic,dl		Make sure it's not atomic
	tze	displace_ok-*,ic	OK, go ahead
displace_tsx4:
	tsx4	bad_arg-*,ic	signal error.
	staq	ap|-4		replace argument,
	tra	displace-*,ic	and retry.
displace_ok:
	lda	ap|-2		see if second argument is atomic
	cana	Atomic,dl
	tnz	displace_atom	if so, replace with `(progn (,y))
	ldaq	ap|-2,*		otherwise, get (car y)
	staq	ap|-4,*		(rplaca x (car y))
	eax2	2		Now do the cdrs
	ldaq	ap|-2,*x2		(cdr y)
	staq	ap|-4,*x2		(rplacd x (cdr y))
	ldaq	ap|-4		return new x
	eppap	ap|-4
	tra	retrn1-*,ic

displace_atom:
	ldaq	lisp_static_vars_$progn_atom
	staq	ap|-4,*		(rplaca x 'progn)
	eax7	4,x7		Make way for calling ncons
	sprilp	ab|-4,x7		save lp
	stcd	ab|-2,x7		and return location
	tra	lisp_alloc_$ncons_ 
	eax2	2		store in cdr
	staq	ap|-2,*x2		(rplacd x (ncons y))
	ldaq	ap|-2		return new x
	eppap	ap|-2
	tra	retrn1-*,ic

"	routine to get 3rd arg as a fixed number in x3.
"	it may signal a correctable error.
"
get_count:
	eppap	ap|6,x5		make sure no more than three args exist.
	ldaq	ap|-2		get count arg
	eppap	ap|-2
chk_count:cmpa	fixnum_type,dl
	tnz	get_count_tsx4-*,ic
	cmpq	0,dl		check for negative argument.
	tpl	good_count-*,ic
get_count_tsx4:
	tsx4	bad_arg-*,ic	call bad argument signaller.
	tra	chk_count-*,ic	and try again.
good_count:
	eax3	0,ql		get count in x3
	tra	0,x6		return
"
	segdef	setq
setq:	eppap	ap|4		get room
	ldaq	ab|nil		get default return value.
nxt_setq: lxl0	ap|-6		load type of fsubr arg.
	canx0	Atomic,du		and check for end.
	tze	more_setq-*,ic	if no end continue.
	eppap	ap|-6		pop off stack
	tra	retrn1-*,ic	and return
more_setq:ldaq	ap|-6,*		load first of list.
chk_name: cana	Atsym,dl		see if atomic.
	tnz	good_atom-*,ic
setq_tsx4:
	tsx4	bad_arg-*,ic	signal bad argument.
	tra	chk_name-*,ic	and retry if new value returned.
good_atom:cmpaq	ab|nil		see if trying to setq nil.
	tze	set_nil-*,ic	signal uncorrectable error if so.
	staq	ap|-4		remember thing set.
	eppbp	ap|-6,*		get next of list
	eppbp	bp|2,*		..
	ldaq	bp|0		get value
	staq	ap|-2
	ldaq	bp|2		get rest of list
	staq	ap|-6		and leave for next time.
	eax7	4,x7		get room for call to eval
	eax5	-2		and set number of args
	sprilp	ab|-4,x7		save our lp, which is same as eval's
	stcd	ab|-2,x7		and save return address.
	tra	<lisp_>|[eval_]	call eval
	staq	ap|-2,*		setq the atom we saved.
	eppap	ap|2		get back space for eval call.
	tra	nxt_setq-*,ic

	segdef	set
set:	ldaq	ap|-4		load first arg.
retry_set:
	cana	Atsym,dl		check atom.
	tnz	set_atm-*,ic
set_tsx4:
	tsx4	bad_arg-*,ic	signal correctable error
	staq	ap|-4		reset arg.
	tra	retry_set-*,ic	and try again
set_atm:	cmpaq	ab|nil		check for set of nil.
	tze	set_nil-*,ic	and signal error if so.
	ldaq	ap|-2		load value.
	staq	ap|-4,*		and store it
	eppap	ap|-4		pop stack
	tra	retrn1-*,ic

set_nil:	eax7	2,x7		we want to signal error
	lda	nihil_ex_nihile,dl
	sta	ab|-2,x7		push code on stack
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	push
	eppap	null_arg_list-*,ic
	short_call 	<lisp_error_>|[lisp_error_]
	drl	0,dl		should never get here.
	even
null_arg_list:
	oct	4
	oct	0
one_arg:
	oct	2000004,0
"
"	procedure to signal the correctable bad argument condition.
"	called with tsx4, with aq containing bad argument,
"	x6 containing data which needs to be saved (as perhaps a return address)
"	and which returns with aq set to replacement value.
"
bad_arg:	eppap	ap|2		get room for arg to lisp_error_
	staq	ap|-2		and save value.
	eax7	4,x7		get some room on unmkd_pdl
	stx6	ab|-3,x7		save x6 for caller.
	sxl5	ab|-3,x7		also save x5 for lsubrs.
	stx4	ab|-4,x7		save our return address

	" get code for function name into q, based on our caller's
	" address in x4, except when called from get_count in which
	" case the value is already in x0 (with minus sign).

	cmpx4	get_count_tsx4+1,du
	tnz	get_my_name-*,ic
	eaq	0,x0
	qrs	18
	tra	got_name-*,ic

get_my_name:
	eaq	-name_tbl_len	search table of tsx4 addresses.
search_for_name:
	cmpx4	name_tbl,qu
	tze	4,ic		found it
	eaq	1,qu		not found, keep looking
	tnz	search_for_name-*,ic
	tra	got_name-*,ic	" not found, will use zero
				" should'nt happen anyway
	ldq	name_tbl,qu	found, get code in low half
	qls	18		extend sign bit
	qrs	18
got_name:
	lda	bad_arg_correctable,dl	load error code
	staq	ab|-2,x7		and push it
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	push
	eppap	null_arg_list-*,ic
	short_call	<lisp_error_>|[lisp_error_]
	eaa	sp|16,*		back up stack
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	eppap	<lisp_static_vars_>|[stack_ptr],*
	stz	ab|in_pl1_code
	ldx4	ab|-2,x7		reload return address
	ldx6	ab|-1,x7		and x6 for caller.
	lxl5	ab|-1,x7	also x5 for lsubrs.
	eax7	-2,x7
	ldaq	ap|-2		reload new value
	eppap	ap|-2		and reset stack.
	tra	0,x4		return to caller.

	even
random_init:
	oct	267762113337,155256071112
				"This is the initial value for the random number generator.
	segdef	random		Lisp lsubr to return a random number.
				"With no args it returns a random number, with an arg it resets to inital value.
random:	cmpx5	0,du		See if there are any args (x5 contains -2*number_of_args).
	tze	random0-*,ic	If none, go to return a random number.
	ldaq	ap|0,x5		get argument.
chk_random:
	cmpaq	ab|nil
	tze	init_random	if nil, restart sequence
	cmpa	fixnum_type,dl	see if fixnum
	tze	random_bounded
random_tsx4:
	tsx4	bad_arg
	staq	ap|0,x5			store new val away.
	tra	chk_random
init_random:
	ldaq	random_init	get the initial value.
	staq	<lisp_static_vars_>|[hi_random]
				"And then store it.
	ldaq	ap|-2		Get the argument, to return it.
	eppap	ap|0,x5		Pop off the arg(s) from the marked pdl.
	tra	retrn1-*,ic	And go to the common return sequence.
random0:	eax0	retrn1		set return operator.
random1:	ldaq	<lisp_static_vars_>|[hi_random]
				"First load the aq with two numbers, H(q) and L(q).
	sta	<lisp_static_vars_>|[lo_random]
				"The next state for the low part, L(q+1), is just the high part, H(q).
	lrl	1		Now right shift everthing in the aq one cell.
	erq	<lisp_static_vars_>|[lo_random]
				"Do an exclusive or between H(q) and L(q) that has been right-shifted.
	stq	<lisp_static_vars_>|[hi_random]
				"And this becomes the high part.
				"Or H(q+1) = H(q) +O ((2**36)*H(q) + L(q))/2
	lda	fixnum_type,dl	We will return H(q+1) as a number.
	tra	0,x0		return to caller.

random_bounded:
	lda	ap|1,x5		load argument.
	cmpa	2,dl
	tmi	ret_zero		if arg < 2 then always return zero.
	tsx0	random1
	cmpq	0,dl		check for negative result.
	tpl	2,ic
	negl	0		negate q...note that a cannot be 4000000000..
	div	ap|1,x5		divide by the argument.
	lrl	36		shift remainder to q
	lda	fixnum_type,dl
	eppap	ap|0,x5		pop stack
	tra	retrn1
ret_zero:	ldaq	fixnum_zero
	eppap	ap|0,x5
	tra	retrn1

"

" table of tsx4 addresses (du) and corresponding function name codes (dl)

	zero	rplaca_tsx4+1,fn_rplaca
	zero	setq_tsx4+1,fn_setq
	zero	set_tsx4+1,fn_set
	zero	oddp_tsx4+1,fn_oddp
	zero	random_tsx4+1,fn_random
	zero	getch_tsx4+1,fn_getchar
	zero	getch_tsx4_2+1,fn_getchar
	zero	zerop_tsx4+1,fn_zerop
	zero	displace_tsx4+1,fn_displace
name_tbl:
	equ	name_tbl_len,9

	end




		    lisp_reader_alm_.alm            11/05/86  1612.7r w 11/04/86  1039.2      232551



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
" alm garbage for reader

" 29 Nov 1972, D. A. Moon
" Modified 28 Mar 73 for new I/O kludge
" Modified 4 August 1973 for fast chrct, linel
"	**** this modification makes this routine incompatible with the 645 processor
" modified 19 October 1973 by DAM for new syntax bits, new iochan format
 " modified 74.09.21 by DAM to accept t for tty as well as nil

	segdef	powers_of_ten

	entry	left_shift,tyi,tyipeek,readch,ascii_alm,tyo_alm

	tempd	argl(4)
	temp	temp
	equ	save_bp,26		the arg-ptr save loc (kludge)

	bool	NL,12			newline

	segref	lisp_static_vars_,obarray,ctrlW,tty_output_chan,read_print_nl_sync,rdr_state,ctrlQ,tty_input_chan
	segref	lisp_static_vars_,ctrlR,infile,outfiles,readtable
	equ	status_terpri,296		offset of status_terpri in read_table

" use of registers

" x0	calls by tsx0
" x1	-> eppbp ext_entry instruction for call_out
" x2 	temp
" x3	temp
" x4	-> failure exit, which switches to pl1 version of same routine when hard case
" x5	-2*nargs for lsubrs
" x6	temp
" x7	unmkd pdl ptr

" bp	-> iochan block.  Also ptr temp
" ap	mkd pdl ptr
" lp	-> our linkage section
" lb	temporary

" q	character (right adjusted)
" aq	lisp object




	include	lisp_iochan
	include	lisp_array_fmt
	include	lisp_stack_seg
	include	stack_header
	include	lisp_object_types
	include	lisp_error_codes

	segdef	listen		" random subr for compatibility
listen:	eppbp	tty_input_chan,*	" get number of chars in input buffer
	ldq	bp|iochan.iolength
	sbq	bp|iochan.ioindex
	tpl	2,ic		" make sure positive (?)
	ldq	0,dl
	lda	fixnum_type,dl
	tra	ab|return_op,*

" fast versions of tyi, tyipeek, readch.  If trouble is encountered, the slow versions
" in lisp_reader_ are called.  These are type 1 subrs.

tyi:	eax4	real_tyi			establish failure exit
	tsx0	set_inp
	tsx0	rdinch
	aos	bp|iochan.ioindex
	lda	fixnum_type,dl
" 					the character is in the q reg
	eppap	ap|0,x5
	tra	ab|return_op,*


tyipeek:	eax4	real_tyipeek		establish failure exit
	cmpx5	0,du			any args?
	tnz	0,x4			yes, too hard to do this version of tyipeek here.
					"no one ever uses it anyway so no loss in efficiency.
	tsx0	set_inp
	tsx0	rdinch
	lda	fixnum_type,dl
	tra	ab|return_op,*


" come here if need to use pl1 version of function

real_tyi:	tsx1 	copout
	eppbp	<lisp_reader_>|[real_tyi]

real_tyipeek:
	tsx1	copout
	eppbp	<lisp_reader_>|[real_tyipeek]

real_readch:
	tsx1	copout
	eppbp	<lisp_reader_>|[real_readch]
real_ascii:
	tsx1	call_out0
	eppbp	<lisp_reader_>|[ascii]

real_tyo:	tsx1	copout
	eppbp	<lisp_print_>|[tyo]


copout:	eaq	0,x5			put -2*nargs as lisp number
	qrs	18
	lda	fixnum_type,dl
	eppap	ap|2
	staq	ap|-2
" routine to call out to pl1 program.


" called with x1 -> eppbp instrruction for entry to be called
" returns by ab|return_op

call_out0:
	tsx0	call_out
	tra	ab|return_op,*

" this one returns to x0


call_out:	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	push				" this macro better not change x0, x1 !!
	xec	0,x1			load bp with addr of ext entry
	call	bp|0			must make null arg list, save index regs

	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eaa	sp|16,*
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	eppap	<lisp_static_vars_>|[stack_ptr],*
	stz	ab|in_pl1_code
	ldaq	ap|-2
	eppap	ap|-2
	tra	0,x0




" ascii function

ascii_alm:
	eax4	real_ascii			establish failure exit
	ldaq	ap|-2
	cmpa	fixnum_type,dl			check for valid arg
	tnz	0,x4
	cmpq	128,dl
	trc	0,x4
	tsx0	get_sing_char
	eppap	ap|-2
	tra	ab|return_op,*


readch:	eax4	real_readch			establish failure exit
	tsx0	set_inp
	tsx0	rdinch
	epplb	bp|0				save ptr to iochan through get_sing_char

	tsx0	get_sing_char
	eppap	ap|0,x5				now return the character atom from the obarray
	aos	lb|iochan.ioindex				bumping iochan.ioindex
	tra	ab|return_op,*

" routine to get character atom from obarray, character in q
" uses bp,aq,x6

get_sing_char:
	qls	1
	eax3	0,ql				for later use in indexing the obarray
	ldaq	obarray,*				is obarray really an array?
	cana	Array,dl
	tze	0,x4				no, fail
	eppbp	obarray,*				-> atom
	eppbp	bp|0,*				-> array_info
	ldx6	bp|array_info.type
	cmpx6	Obarray_array,du
	tnz	0,x4				no, fail

	eppbp	bp|array_data_ptr,*
	ldaq	bp|511*2,x3			valid obarray, examine char obj cell
	cmpaq	ab|nil				has char obj been interned yet?
	tze	0,x4				no, fail
	tra	0,x0				yes, succeed



" tyo function
"   this is a simplified version of the character output code in lisp_print_

tyo_alm:	eax4	real_tyo				establish failure exit
	ldaq	ap|0,x5				make sure argument is OK
	cmpa	fixnum_type,dl			has to be a number,
	tnz	0,x4
	cmpq	128,dl				between 0 and 128.
	trc	0,x4				(tricky)

" now find out what destinations we're going to send the output to

	eax2	-1				clear sent-to-tty flag
	eppap	ap|6,x5				leave three cells for munging around in

" the character to be output is in ap|-5

" this is dump_character from lisp_print_.pl1
" but it has get_dest in it too, done in line instead of by setting flags

output_char:
	cmpx5	-2,du				should maybe go to tty?
	tnz	tyo.3
	ldaq	ctrlW,*				yes, if ^w allows it
	cmpaq	ab|nil
	tnz	2,ic
	tsx3	to_tty				yes.

" now send output to dest spec by ^r, outfiles

	ldaq	ctrlR,*
	cmpaq	ab|nil
	tze	tyo.5				no.
	ldaq	outfiles,*
	tra	to_list_join

"this is code to put to special channel (tyo with 2 args)

tyo.3:
	ldaq	ap|-4				special channel, look at it
	cana	lisp_ptr.type,dl			list?
	tze	to_list				yes, go do a do loop
to_one:						"no, just output to one
	tsx3	to_file
	tra	tyo.5

"this is do loop to output to a list of files in ap|-4

to_list:
	ldaq	ap|-4,*
	tsx3	to_file
	eppbp	ap|-4,*
	ldaq	bp|2
to_list_join:
	staq	ap|-4
	cana	lisp_ptr.type,dl				more to list?
	tze	to_list

tyo.5:						"all done, return t.
	ldaq	ab|true
	eppap	ap|-6
	tra	ab|return_op,*


to_file:
	cmpaq	ab|nil
	tze	to_tty
	cmpaq	ab|true
	tze	to_tty
	cana	File,dl
	tnz	to_file_ok
	staq	ap|-2
	eax7	2,x7
	lda	bad_output_dest,dl
	sta	ab|-2,x7
	eax1	lisp_error_
	tsx0	call_out
	ldaq	ap|-2
	tra	to_file
lisp_error_:
	eppbp	<lisp_error_>|[lisp_error_]

to_file_ok:
	easpbp	0,au
	eawpbp	0,qu
	ldq	ap|-5
	tsx6	to_anyplace
	tra	tyo_nl_maybe


to_tty:
	eax2	1,x2				check to-tty-flag
	tnz	0,x3				only send to tty once
	ldq	ap|-5
	eppbp	tty_output_chan,*
	szn	read_print_nl_sync
	tze	3,ic
	cmpq	NL,dl
	tze	2,ic
	tsx6	to_anyplace

	stz	read_print_nl_sync
tyo_nl_maybe:
	epplb	readtable,*		-> value cell of atom readtable
	epplb	lb|0,*			-> readtable array
	szn	lb|status_terpri		put status_terpri in indicators
	tmi	flush2			(status terpri) /= nil, no extra NL.
	lda	bp|iochan.flags
	cana	iochan.image_mode,du
	tnz	flush2
	lda	bp|iochan.linel
	tze	flush2
	cmpa	bp|iochan.charpos
	tpnz	flush2			linel > charpos, don't need an extra NL
	ldq	NL,dl			type extra NL.
	tsx6	to_anyplace
	lda	iochan.extra_nl_done,du
	orsa	bp|iochan.flags

flush2:
	lda	bp|iochan.flags
	cana	iochan.seg,du
	tnz	0,x3
	cana	iochan.charmode,du
	tnz	5,ic
	cana	iochan.interactive,du
	tze	0,x3
	cana	iochan.nlsync,du
	tze	0,x3

	cana	iochan.write,du
	tnz	0,x3
	szn	bp|iochan.ioindex
	tmoz	0,x3

	eax0	0,x3

" empty a buffer, pointed at by bp.  return to x0

empty_buff:
	eax4	0,ql				save the character in the q reg
	tsx1	ipush
	eppbp	sp|save_bp,*
	eppap	sp|save_bp
	spriap	argl+2
	eppap	q1qb
	spriap	argl+4
	eppap	temp
	spriap	argl+6
	lda	bp|iochan.flags
	cana	not_ok_to_write,du
	tze	flush3
	eppbp	<lisp_io_control_>|[fix_not_ok_iochan]
	tsx1	icall
	szn	temp
	tnz	popret
flush3:
	eppap	<lisp_static_vars_>|[stack_ptr],*
	epbpab	ap|0
	ldaq	ab|nil
	staq	ap|-2
	eppap	ap|-2
	spriap	argl+4
	eppbp	<lisp_io_control_>|[end_of_block]
	tsx1	icall
popret:	eaq	0,x4				reload the char into q from x4
	qrl	18
	lxl4	temp
	tsx1	ipop
	tra	0,x0

q1qb:	oct	400000000000				"1"b
	even
three_args:
	zero	6,4
	zero	0,0
ipush:	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	eppap	bp|0				make bp get saved in sp|26 (= sp|save_bp)
	push
	tra	0,x1

ipop:	eppbp	sp|save_bp,*			restore bp
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eaa	sp|16,*
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	eppap	<lisp_static_vars_>|[stack_ptr],*
	stz	ab|in_pl1_code
	tra	0,x1

icall:	ldaq	three_args
	staq	argl
	call	bp|0(argl)
	tra	0,x1



to_any_ch_code:
	cmpx4	0,du
	tnz	0,x6
	tra	to_anyplace_aa

to_anyplace:
	lda	bp|iochan.flags
	cana	not_ok_to_write,du
	tze	3,ic
	 tsx0	 empty_buff
	 tra	 to_any_ch_code
	lda	bp|iochan.ioindex
	cmpa	bp|iochan.iolength
	tze	-4,ic
	lda	flag_reset_mask,du
	ansa	bp|iochan.flags

to_anyplace_aa:
	lda	bp|iochan.ioindex
	eax4	0,al
	anx4	3,du
	ars	2
	epplb	bp|iochan.ioptr,*al
	eaa	0,ql				save char for compares
	xec	qls,x4				align char in q
	xec	stbq,x4
	aos	bp|iochan.ioindex
" check for control character, if so do specially good things.

	cmpa	=o40,du
	tmi	tyo_control_table,au*	control character, do specially good things.
	cmpa	=o177,du
	tpl	0,x6			rubout - don't advance charpos
	aos	bp|iochan.charpos		normal character, advance charpos (caller checks for endofline)
	tra	0,x6


tyo_control_table:
	arg	0,x6			null - do nothing
	arg	0,x6			^A - do nothing
	arg	0,x6			^B - do nothing
	arg	0,x6			^C - do nothing
	arg	0,x6			^D - do nothing
	arg	0,x6			^E - do nothing
	arg	0,x6			^F - do nothing
	arg	0,x6			^G - do nothing
	arg	tyo_backspace		BS - subtract one from charpos
	arg	tyo_tab			HT - adjust charpos to next tabstop
	arg	tyo_newline		NL - adjust charpos, linenum
	arg	0,x6			^K - do nothing
	arg	tyo_newpage		NP - adjust charpos, linenum, pagenum
	arg	tyo_car_ret		CR - adjust charpos
	arg	0,x6			^N - do nothing
	arg	0,x6			^O - do nothing
	arg	0,x6			^P - do nothing
	arg	0,x6			^Q - do nothing
	arg	0,x6			^R - do nothing
	arg	0,x6			^S - do nothing
	arg	0,x6			^T - do nothing
	arg	0,x6			^U - do nothing
	arg	0,x6			^V - do nothing
	arg	0,x6			^W - do nothing
	arg	0,x6			^X - do nothing
	arg	0,x6			^Y - do nothing
	arg	0,x6			^Z - do nothing
	arg	0,x6			$O  - do nothing
	arg 	0,x6			\034 - do nothing
	arg	0,x6			\035 - do nothing
	arg	0,x6			\036 - do nothing
	arg	0,x6			\037 - do nothing


tyo_newline:
	stz	bp|iochan.charpos
	lda	iochan.nlsync,du
	orsa	bp|iochan.flags
	aos	bp|iochan.linenum
	lda	bp|iochan.pagel
	tze	0,x6			0 pagel = infinite
	cmpa	bp|iochan.linenum		page exceeded?
	tpnz	0,x6			no, return
tyo_newpage:
	stz	bp|iochan.charpos			NP causes return to left margin
	stz	bp|iochan.linenum
	aos	bp|iochan.pagenum		advance to next page

" page overflow - invoke endpagefn

	lda	bp|iochan.flags
	cana	iochan.interactive,du		if this is the tty, can't endpage
	tnz	0,x6
	ldaq	bp|iochan.function
	cmpaq	ab|nil
	tze	0,x6			no endpagefn - leave
	eax5	-4
	eppap	ap|4
	staq	ap|-4			function to apply
	eax7	6,x7			prepare type-1 call
	spribp	ab|-2,x7			put type bits in bp
	ldaq	ab|-2,x7
	ora	File,dl
	staq	ap|-2			argument to endpagefn is the file object
"					assume can't happen to tty
	sprilp	ab|-4,x7
	stx6	ab|-6,x7			save registers 3 and 6
	stx3	ab|-5,x7
	epplp	ab|system_lp,*
	stcd	ab|-2,x7
	tra	<lisp_>|[funcall]

	ldx6	ab|-2,x7			restore registers 3 and 6
	ldx3	ab|-1,x7
	eax7	-2,x7			pop extraneous cruft off unmarked stack
	tra	0,x6


tyo_backspace:
	lca	1,dl
	szn	bp|iochan.charpos
	tze	2,ic
	 asa	 bp|iochan.charpos
	tra	0,x6

tyo_tab:
	ldq	bp|iochan.charpos
	adq	10,dl
	div	10,dl
	mpy	10,dl
	stq	bp|iochan.charpos
	tra	0,x6

tyo_car_ret:
	stz	bp|iochan.charpos
	tra	0,x6


" xec vectors for storing char from q into word pointed at by sn,wo=lb, co=x4

qls:	qls	27
	qls	18
	qls	9
	nop	0,du

stbq:	stbq	lb|0,40
	stbq	lb|0,20
	stbq	lb|0,10
	stbq	lb|0,04

"fast type-0 lsubrs to examine and modify certain file-object attributes.

	segdef	chrct,linel,charpos,pagel,linenum,pagenum

chrct:	tsx1	process_file_arg		call common routine
	eppbp	<lisp_io_fns_>|[chrct]	instruction to get to pl1 code if can't do it here
	xed	pick_up_chrct		instruction to load the value into q, lb -> iochan
	xed	put_down_chrct		instruction to store q into the value, lb -> iochan

	even
pick_up_chrct:
	ldq	lb|iochan.linel		convert charpos to chrct
	sbq	lb|iochan.charpos

put_down_chrct:
	ldq	lb|iochan.linel		convert chrct to charpos
	xed	*+1
	sbq	ap|-1			(chrct is known to be here as well as in q)
	stq	lb|iochan.charpos

linel:	tsx1	process_file_arg
	eppbp	<lisp_io_fns_>|[linel]
	ldq	lb|iochan.linel
	stq	lb|iochan.linel

charpos:	tsx1	process_file_arg
	eppbp	<lisp_io_fns_>|[charpos]
	ldq	lb|iochan.charpos
	stq	lb|iochan.charpos

pagel:	tsx1	process_file_arg
	eppbp	<lisp_io_fns_>|[pagel]
	ldq	lb|iochan.pagel
	stq	lb|iochan.pagel

linenum:	tsx1	process_file_arg
	eppbp	<lisp_io_fns_>|[linenum]
	ldq	lb|iochan.linenum
	stq	lb|iochan.linenum

pagenum:	tsx1	process_file_arg
	eppbp	<lisp_io_fns_>|[pagenum]
	ldq	lb|iochan.pagenum
	stq	lb|iochan.pagenum


process_file_arg:
	cmpx5	-2,du		get entry?
	tnz	process_file_arg_2	no.
	ldaq	ap|-2		yes, get file object
	cmpaq	ab|nil		tty?
	tze	process_file_arg_nil
	cmpaq	ab|true
	tze	process_file_arg_nil
	cana	File,dl
	tze	process_file_arg_err
	epplb	ap|-2,*		no, pick up ptr to file object
process_file_arg_nil_a:
	xec	1,x1		pick up value to be gotten
	lda	fixnum_type,dl
"	tra	popaj		and return
popaj:	eppap	ap|0,x5		pop off arguments.
	tra	bp|0		and return to caller

process_file_arg_nil:
	tsx2	get_file_object_of_nil
	tra	process_file_arg_nil_a

get_file_object_of_nil:
	link	tty_output_chan_l,<lisp_static_vars_>|[tty_output_chan],*
	epplb	ab|system_lp,*
	epplb	lb|tty_output_chan_l,*	lb := lisp_static_vars_$tty_output_chan
	tra	0,x2

process_file_arg_err:
"
" can't do it here, escape out to the pl1 code
" first must pretend we were a type-1 subr

	eax7	4,x7
	spribp	ab|-2,x7
	sprilp	ab|-4,x7

" now go away to pl1

	epplp	ab|system_lp,*
	tra	copout		0,x1 is eppbp instruction to pl1 version


process_file_arg_2:
	cmpx5	-4,du			called with 2 args
	tnz	process_file_arg_err

	ldaq	ap|-4			file-object argument
	cmpaq	ab|nil
	tze	process_file_arg_2_nil
	cmpaq	ab|true
	tze	process_file_arg_2_nil
	cana	File,dl
	tze	process_file_arg_err
	epplb	ap|-4,*
process_file_arg_3:
	ldaq	ap|-2			pick up number to be stored
	cmpa	fixnum_type,dl
	tnz	process_file_arg_err
	xec	2,x1			do the store
	tra	popaj			and return (result = 2nd arg is in aq)

process_file_arg_2_nil:
	tsx2	get_file_object_of_nil
	tra	process_file_arg_3

" routines copied from lisp_reader_

" set_inp sets bp to the appropriate iochan.  If input is from a read list
"  or if end of file or end of buffer has been reached, returns to 0,x4
"  If successful, returns to 0,x0.

set_inp:	ldq	rdr_state			check for macro char in readlist causing special case
	cmpq	2,dl
	tze	0,x4			yes, can't handle it here - go to lisp_reader_
" look for special channel specified by an argument
	eax3	0,x5			set up to scan arg list
	tze	cke
cka:	ldaq	ap|0,x3
	cana	File,dl
	tnz	spchan
	cmpaq	ab|nil
	tze	set_inp_tty
	cmpaq	ab|true
	tze	set_inp_tty
	eax3	2,x3
	tnz	cka
cke:	ldaq	ctrlQ,*
	cmpaq	ab|nil
	tnz	uread
set_inp_tty:
	eppbp	tty_input_chan,*
set_inp_aa:
	ldq	bp|iochan.ioindex
	cmpq	bp|iochan.iolength
	tpl	0,x4			EOF - can't handle it here

	tra	0,x0			WIN.

spchan:	eppbp	ap|0,x3*
	tra	set_inp_aa

uread:	ldaq	<lisp_static_vars_>|[infile],*
	cana	File,dl
	tze	set_inp_tty
	easpbp	0,au
	eawpbp	0,qu
	tra	set_inp_aa


" rdinch reads in one character, returns it right justified in the q
"  bp must point at the iochan block.



rdinch:	lda	bp|iochan.ioindex
	ldq	0,du
	lrs	2			divide by 4
	qrl	36-2			right justify the remainder
	lda	bp|iochan.ioptr,*al		get word containing character
	lrl	shifts,ql*		right justify the character
	anq	=o177,dl			mask off to (7 bit) character 
	cmpq	=o036,dl			bsg ctrl prefix?
	tze	0,x4			yes, only PL/I reader handles this.
	cmpx4	real_tyipeek,du		don't do vertical motion cruft if
	tze	0,x0			this is tyipeek.

" at this point character is in q, bp -> iochan.  we handle vertical motion here.

	lda	initial_readtable,ql	this is kludgy way to test for NL and NP
	cana	2000,du			vertical_motion right-shifted 18.
	tze	0,x0			ordinary character, return.

	cmpq	NL,dl
	tnz	vm01

" newline, bump linenum

	stz	bp|iochan.charpos
	aos	bp|iochan.linenum
	lda	bp|iochan.pagel
	tze	0,x0			pagel of 0 = infinite
	cmpa	bp|iochan.linenum		end of page?
	tpnz	0,x0			no, return
	stz	bp|iochan.linenum		page exceeded, bump pagenum
	aos	bp|iochan.pagenum
	tra	0,x0			NOTE - it is not necessary to call endpagefn for input files.

vm01:	cmpq	12,dl			NP - this check is unnecc but do it anyway
	tnz	0,x0
	stz	bp|iochan.charpos		adnace to new page
	stz	bp|iochan.linenum
	aos	bp|iochan.pagenum
	tra	0,x0

shifts:	arg	27+36
	arg	18+36
	arg	9+36
	arg	0+36


left_shift:
	lda	ap|4,*			get shift count
					" - should check for bounds here.
	ldq	ap|2,*			get number to be shifted
	qls	0,al			shift it the right amount
	stq	ap|2,*			put it back
	short_return			and exit


" table of double floating powers of ten, from 10**-38 up to 10**+38

	even
powers_of_ten:
	oct	404663437347,325170710457
	oct	414420163520,505213435275
	oct	422524220444,626456344554
	oct	430651264555,774172035707
	oct	440411660744,575514222534
	oct	446514235135,735037267263
	oct	454637304365,324247145140
	oct	464403472631,304550377174
	oct	472504411377,565702477033
	oct	500625513677,523263216642
	oct	506773036657,450140062412
	oct	516474723215,571074037446
	oct	524614110061,127313047357
	oct	532757132075,355175661253
	oct	542465370246,324216516653
	oct	550602666320,011262242426
	oct	556743444004,013536713133
	oct	566456166402,407233236771
	oct	574571624103,111102106567
	oct	602730171123,733322530325
	oct	612447113564,351103527205
	oct	620560736521,443324455046
	oct	626715126245,754211570257
	oct	636440165747,563526053155
	oct	644550223341,520453466010
	oct	652702270232,044566403412
	oct	662431363140,226752042146
	oct	670537657770,274544452600
	oct	676667633766,353675565340
	oct	706422701372,023326451314
	oct	714527461670,430214163577
	oct	722655376246,536257220537
	oct	732414336750,132755432333
	oct	740517426542,161550741022
	oct	746643334272,616103131227
	oct	756406111564,570651767636
	oct	764507534121,727024365606
	oct	772631463146,314631463147
	oct	002400000000,000000000000
	oct	010500000000,000000000000
	oct	016620000000,000000000000
	oct	024764000000,000000000000
	oct	034470400000,000000000000
	oct	042606500000,000000000000
	oct	050750220000,000000000000
	oct	060461132000,000000000000
	oct	066575360400,000000000000
	oct	074734654500,000000000000
	oct	104452013710,000000000000
	oct	112564416672,000000000000
	oct	120721522450,400000000000
	oct	130443023471,240000000000
	oct	136553630407,510000000000
	oct	144706576511,432000000000
	oct	154434157115,760200000000
	oct	162543212741,354240000000
	oct	170674055531,647310000000
	oct	200425434430,110475000000
	oct	206532743536,132614200000
	oct	214661534465,561357240000
	oct	224417031701,446725444000
	oct	232522640261,760512755000
	oct	240647410336,354635550200
	oct	250410545213,024002441120
	oct	256512676455,631003151344
	oct	264635456171,177204003635
	oct	274402374713,617422402302
	oct	302503074076,563327102762
	oct	310623713116,320214723556
	oct	316770675742,004260110511
	oct	326473426555,202556055315
	oct	334612334310,443311470600
	oct	342755023372,554174006740
	oct	352464114134,543515404254
	oct	360601137163,674440705327
	oct	366741367020,653551066614
	oct	376454732312,413241542167

""" here is the initial readtable, extracted from lisp_reader_init_.pl1

	segdef	initial_readtable

" NB: the macro_table portion is omitted, and must
" be supplied by anyone who copies this table into a LISP array.

" define syntax bits

	bool	forcefeed,4000000000	(ITS)
	bool	vertical_motion,2000000000	NL, NP
	bool	string_quote_exp,1000000000	", E
	bool	special,400000000		
	bool	single_char_object,200000000	standalone pname
	bool	blank,100000000			space, tab, comma, etc.
	bool	lparn,40000000			(, super-(
	bool	dotted_pair_dot,20000000		. for cons
	bool	rparn,10000000			), super-)
	bool	macro,4000000			character macro
	bool	slashifier,2000000		escape char 
	bool	rubout,1000000			(ITS)
	bool	slash_if_first,400000	print control
	bool	decimal_point,200000	. for numbers
	bool	slash_if_not_first,100000	print control
	bool	slash_output,500000		..	
	bool	bit12,40000		changes meaning of other bits
	bool	splice,40000
	bool	shift_scale,20000		^ or _	
	bool	plus_minus,10000		+ or -	
	bool	digit,4000		0,...,9	
	bool	extd_alpha,2000		random chars as alpha 
	bool	alpha,1000		alphabetic



""" Here are the 132 syntax table entries
initial_readtable:

	vfd	36/special+slash_output		\000
	vfd	36/special+slash_output		^A
	vfd	36/special+slash_output		^B	- these random ctrl chars are ignored
	vfd	36/special+slash_output		^C
	vfd	36/special+slash_output		^D
	vfd	36/special+slash_output		^E
	vfd	36/special+slash_output		^F
	vfd	36/special+slash_output		^G
	vfd	36/extd_alpha			BS - allow underlined pnames
	vfd	36/special+blank+slash_output		HT
	vfd	36/special+blank+vertical_motion+slash_output	NL
	vfd	36/special+blank+slash_output		VT
	vfd	36/special+blank+vertical_motion+slash_output	NP
	vfd	36/special+blank+slash_output		CR
	vfd	36/special+slash_output		^N	- more worthless control chars
	vfd	36/special+slash_output		^O
	vfd	36/special+slash_output		^P
	vfd	36/special+slash_output		^Q
	vfd	36/special+slash_output		^R
	vfd	36/special+slash_output		^S
	vfd	36/special+slash_output		^T
	vfd	36/special+slash_output		^U
	vfd	36/special+slash_output		^V
	vfd	36/special+slash_output		^W
	vfd	36/special+slash_output		^X
	vfd	36/special+slash_output		^Y
	vfd	36/special+slash_output		^Z
	vfd	36/extd_alpha			altmode
	vfd	36/special+slash_output		\034
	vfd	36/special+slash_output		\035
	vfd	36/special+slash_output		\036
	vfd	36/special+slash_output		\037
	vfd	36/special+blank+slash_output		SP
	vfd	36/extd_alpha			!
	vfd	36/special+string_quote_exp+bit12+slash_output	"
	vfd	36/extd_alpha			#
	vfd	36/extd_alpha			$
	vfd	36/extd_alpha			%
	vfd	36/extd_alpha			&
	vfd	36/special+macro+slash_output		'
	vfd	36/special+lparn+slash_output		(
	vfd	36/special+rparn+slash_output		)
	vfd	36/extd_alpha			*
	vfd	36/slash_if_first+plus_minus		+
	vfd	36/special+blank+slash_output		,
	vfd	36/slash_if_first+plus_minus+bit12	-
	vfd	36/special+dotted_pair_dot+slash_output+decimal_point	.
	vfd	36/special+slashifier+slash_output	/
	vfd	36/slash_if_first+digit		0
	vfd	36/slash_if_first+digit		1
	vfd	36/slash_if_first+digit		2
	vfd	36/slash_if_first+digit		3
	vfd	36/slash_if_first+digit		4
	vfd	36/slash_if_first+digit		5
	vfd	36/slash_if_first+digit		6
	vfd	36/slash_if_first+digit		7
	vfd	36/slash_if_first+digit		8
	vfd	36/slash_if_first+digit		9
	vfd	36/extd_alpha			:
	vfd	36/special+macro+slash_output+splice	semicolon
	vfd	36/extd_alpha			<
	vfd	36/extd_alpha			=
	vfd	36/extd_alpha			>
	vfd	36/extd_alpha			?
	vfd	36/extd_alpha			@
	vfd	36/alpha				A
	vfd	36/alpha				B
	vfd	36/alpha				C
	vfd	36/alpha				D
	vfd	36/string_quote_exp+alpha		E
	vfd	36/alpha				F
	vfd	36/alpha				G
	vfd	36/alpha				H
	vfd	36/alpha				I
	vfd	36/alpha				J
	vfd	36/alpha				K
	vfd	36/alpha				L
	vfd	36/alpha				M
	vfd	36/alpha				N
	vfd	36/alpha				O
	vfd	36/alpha				P
	vfd	36/alpha				Q
	vfd	36/alpha				R
	vfd	36/alpha				S
	vfd	36/alpha				T
	vfd	36/alpha				U
	vfd	36/alpha				V
	vfd	36/alpha				W
	vfd	36/alpha				X
	vfd	36/alpha				Y
	vfd	36/alpha				Z
	vfd	36/extd_alpha			[
	vfd	36/extd_alpha			\
	vfd	36/extd_alpha			]
	vfd	36/extd_alpha+shift_scale		^
	vfd	36/extd_alpha+shift_scale+bit12	_
	vfd	36/extd_alpha			`
	vfd	36/alpha				a
	vfd	36/alpha				b
	vfd	36/alpha				c
	vfd	36/alpha				d
	vfd	36/string_quote_exp+alpha		e
	vfd	36/alpha				f
	vfd	36/alpha				g
	vfd	36/alpha				h
	vfd	36/alpha				i
	vfd	36/alpha				j
	vfd	36/alpha				k
	vfd	36/alpha				l
	vfd	36/alpha				m
	vfd	36/alpha				n
	vfd	36/alpha				o
	vfd	36/alpha				p
	vfd	36/alpha				q
	vfd	36/alpha				r
	vfd	36/alpha				s
	vfd	36/alpha				t
	vfd	36/alpha				u
	vfd	36/alpha				v
	vfd	36/alpha				w
	vfd	36/alpha				x
	vfd	36/alpha				y
	vfd	36/alpha				z
	vfd	36/extd_alpha			{
	vfd	36/special+macro+slash_output			|
	vfd	36/extd_alpha			}
	vfd	36/extd_alpha			~
	vfd	36/special+slash_output		rubout
	vfd	36/special+slashifier+slash_output	"pseudo slash"
	vfd	36/special+lparn+slash_output		"pseudo left parenthesis"
	vfd	36/special+rparn+slash_output		"pseudo right parenthesis"
	zero	special+blank+slash_output		"pseudo space"


""" Here is the translation table

	dec	0
	dec	1
	dec	2
	dec	3
	dec	4
	dec	5
	dec	6
	dec	7
	dec	8
	dec	9
	dec	10
	dec	11
	dec	12
	dec	13
	dec	14
	dec	15
	dec	16
	dec	17
	dec	18
	dec	19
	dec	20
	dec	21
	dec	22
	dec	23
	dec	24
	dec	25
	dec	26
	dec	36			translate altmode to dollar sign
	dec	28
	dec	29
	dec	30
	dec	31
	dec	32
	dec	33
	dec	34
	dec	35
	dec	36
	dec	37
	dec	38
	dec	1			standard quote macro
	dec	40
	dec	41
	dec	42
	dec	43
	dec	44
	dec	45
	dec	46
	dec	47
	dec	48
	dec	49
	dec	50
	dec	51
	dec	52
	dec	53
	dec	54
	dec	55
	dec	56
	dec	57
	dec	58
	dec	2			standard semicolon macro
	dec	60
	dec	61
	dec	62
	dec	63
	dec	64
	dec	65
	dec	66
	dec	67
	dec	68
	dec	69
	dec	70
	dec	71
	dec	72
	dec	73
	dec	74
	dec	75
	dec	76
	dec	77
	dec	78
	dec	79
	dec	80
	dec	81
	dec	82
	dec	83
	dec	84
	dec	85
	dec	86
	dec	87
	dec	88
	dec	89
	dec	90
	dec	91
	dec	92
	dec	93
	dec	94
	dec	95
	dec	96
	dec	97
	dec	98
	dec	99
	dec	100
	dec	101
	dec	102
	dec	103
	dec	104
	dec	105
	dec	106
	dec	107
	dec	108
	dec	109
	dec	110
	dec	111
	dec	112
	dec	113
	dec	114
	dec	115
	dec	116
	dec	117
	dec	118
	dec	119
	dec	120
	dec	121
	dec	122
	dec	123
	dec	3	standard vertical bar macro
	dec	125
	dec	126
	dec	127
	dec	47			pseudo slash
	dec	40			pseudo (
	dec	41			pseudo )
	dec	32			pesudo space


	end




		    lisp_save_alm_.alm              07/06/83  0937.8r w 06/29/83  1542.8       14850



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
	name 	lisp_save_alm_

" This routine fixes all the its pairs in a segment to have real segment numbers
" it is called by the unsaver.
" It is written in alm for extra speed.		(10 Nov 1973, DAM)

	even
al_qu_mask:
	zero	0,-1
	zero	-1,0

	segdef	lisp_save_alm_
lisp_save_alm_:
	" arg 1: ptr of seg to do, chain header
	" arg 2: address of pseudo-segment number table, must be unpacked pointers with ring numbers.
	" also it relies on the fact that it is bound in with lisp_subr_tv_

	epplb	<lisp_subr_tv_>|[tv_begin]

	eppbb	ap|4,*		pick up ptr to segno_table
	eppbb	bb|0,*

	eppap	ap|2,*		-> ptr to seg
	epbpbp	ap|0,*		base of segment to be processed
	eax0	ap|0,*		chain header
	tze	return		if no chain, return to lisp_save_
	sprilb	ap|0		clobber argument with ptr to sys tv for use later

loop:
	ldaq	bp|0,x0		its pair to be fixed up
	eax1	0,au		pseudo segment 0?
	tnz	g0001		 no

	eaq	lb|0,qu		yes.  relocate offset into tv + clear chain field
	ora	ap|0		set system tv segno + ring field + or in its which is ok.
	tra	g0002

g0001:	adx1	bp|0,x0		x1 := 2 x pseudo segno
	anaq	al_qu_mask	au := 0, ql := 0
	ora	bb|-2,x1		set segno + ring + or in its which is OK
g0002:
	lxl1	bp|1,x0		pick up next chain
	staq	bp|0,x0		fix up pointer
	eax0	0,x1		move chain to right register + check if 0
	tnz	loop

return:
	short_return

	end




		    lisp_static_vars_.alm           07/06/83  0937.8r w 06/29/83  1542.8      131850



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
"
" last modified October 1982 to add progn atom.
"

	use lk
	join	/link/lk
	even
	segdef	lisp_static_vars_	lisp communications area
lisp_static_vars_:
	its	-1,1,n		cclist_ptr (totally obsolete)

""" Table of Contents

	segdef	maknum_table_ptr
	segdef	maknum_data
	segdef	maknum_next
	segdef	maknum_mask
	segdef	maknum_left
	segdef	garbage_collect_soon
	segdef	quit_handler_flag
	segdef	binding_reversal_flag
	segdef	evalhook_status,evalhook_atom
	segdef	gc_time
	segdef	gc_mark_bits
	segdef	gcmin,gcmin_fraction,gcsize,gcmax
	segdef	no_snapped_links
	segdef	space_names_atom
	segdef	transparent		switch to make lisp transparent to quits
	segdef	read_print_nl_sync
	segdef	rdr_state,garbage_collect_inhibit,rdr_ptr,rdr_label
	segdef	masked
	segdef	emptying_buffers	 non-negative when lisp_default_handler_ is emptying all stream output buffers
	segdef	pending_ctrl
	segdef	i_am_gcing
	segdef	saved_environment_dir
	segdef	hi_random
	segdef	lo_random
	segdef	ignore_faults
	segdef	stack_ptr
	segdef	unmkd_ptr	pointer to top of unmkd_stack
	segdef	frame_ptrs	the following 6 things must be kept in the same order,
	segdef	binding_top	pointer to top of binding block chain
	segdef	err_recp
	segdef	prog_frame	7 pointers to threaded lists of frames in unmarked stack
	segdef	err_frame
	segdef	catch_frame
	segdef	eval_frame	stuff kept by eval if *rset t
	segdef	unwp_frame	head of unwind-protect frame list
	segdef	arg_list_ptr	needed by status jcl
	segdef	top_level		the top-level read-eval-print loop
	segdef	argatom		used to hold arg list of lexpr(not really an atom)
	segdef	iochan_list	list of all opened iochans (files)
	segdef	subr_block_list	list of all new (fasload) subr blocks
	segdef	garbage_collected_ptrs
	segdef	first_value_atom		for (status system)
	segdef	obarray
	segdef	atomic_constants
	segdef	nil
	segdef	t_atom
	segdef	ctrlD
	segdef	ctrlQ
	segdef	ctrlR
	segdef	ctrlW
	segdef	user_intr_array
	segdef	STAR	atom *
	segdef	PLUS	atom +
	segdef	MINUS	atom -
	segdef	SLASH	atom //
	segdef	base
	segdef	ibase
	segdef	readtable
	segdef	stnopoint		atom *nopoint
	segdef	tty_atom
	segdef	errlist
	segdef	ctrlA		the atom ^a, whose value is interrupted by the CTRL/a input
	segdef	prinlevel,prinlength
	segdef	last_value_atom			for (status system)
	segdef	value_atom
	segdef	readeof_atom			for lisp_error_, eof_in_object err
	segdef	s_atom
	segdef	dollar_p_atom
	segdef	quote_atom
	segdef	array_atom
	segdef	array
	segdef	pname_atom
	segdef	string_atom
	segdef	fixnum_atom
	segdef	fixnum
	segdef	external
	segdef	flonum_atom
	segdef	flonum
	segdef	random_atom
	segdef	bignum_atom
	segdef	list_atom
	segdef	go_atom,return_atom,pdlframe_atom
	segdef	alphalessp_atom
	segdef	function_properties
	segdef	lambda,label,subr,lsubr,fsubr,expr,fexpr
	segdef	funarg,macro,autoload,qarg,qsetarg,qlstfy
	segdef	quotient
	segdef	evalframe_atom
	segdef	arrayindex
	segdef	setq_atom
	segdef	question_mark
	segdef	nouuo_flag,noret_flag
	segdef	quote_macro,semicolon_macro		special flags for builtin macros, used by rdr
	segdef	runtime_atom,time_atom
	segdef	comment_atom,declare_atom
	segdef	close,deletef,filepos,infile,instack,mergef,open
	segdef	outfile,outfiles,rename,stream
	segdef	dsk_atom,crunit_atom,uread_atom,uwrite_atom,old_io_defaults
	segdef	args	for err_break routine in lisp_subr_tv_
	segdef	star_rset
	segdef	err_atom,eval_atom,apply_atom,princ_atom,prin1_atom,print_atom
	segdef	prin1
	segdef	zunderflow
	segdef	toplevel	toplevel function ptr
	segdef	divov_flag
	segdef	plus_status
	segdef	status_gctwa
	segdef	tty_input_chan		-> iochan block for user_input stream
	segdef	tty_output_chan
	segdef	property_list_of_nil
	segdef	number_gc_ptrs
	segdef	number_of_atomic_constants
	segdef	atomic_constants_names
	segdef	template
	segdef	 template_size
	segdef	subsys_recurse_save_size
	segdef	cur_stat_seg
	segdef	cur_stat_pos
	segdef	gc_unwinder_kludge
	segdef	activate_gc_unwinder_kludge
	segdef	cleanup_list_exists
	segdef	cleanup_list
	segdef	defun,expr_hash
	segdef	vertical_bar_macro,eof_atom,progn_atom
	segdef	mulquit_state,mulpi_state
	segdef	deferred_interrupt

garbage_collect_soon:
	dec	0		garbage collection flag

quit_handler_flag:
	oct	0			"1"b means quitting out of a quit handler
	even
gc_time:	dec	0
	dec	0

gc_mark_bits:
	oct	525252000000

""" Bibop-compatible garbage collection parameters

gcmin:	dec	0.5
gcmin_fraction:  oct 400000000000	bit(1)
gcsize:	dec	30000
gcmax:	dec	1000000000

no_snapped_links:  oct 0		flag, "1"b means there are no snapped links in any compiled subr blocks

transparent: oct	0
read_print_nl_sync:
	dec	0		if this is non-zero, read has just read a newline,
				" and if print is to output one, it should suppress it.
garbage_collect_inhibit:
	oct	0		set nonzero by interrupts


masked:	oct	0		"1"b if we are masked against alrm, cput, and ctrl chars
				" i.e. (nointerrupt t) mode.
emptying_buffers:
	dec	-1

i_am_gcing: oct	0				"1"b when garbage-collecting

rdr_state:dec	0			0 = normal, 1 = ios_$read wait, 2 = readlist

	even
rdr_ptr:	its	-1,1			-> current readlist

rdr_label:its	-1,1			label for abnormal exit from  (tti wait)
	its	-1,1

saved_environment_dir:
	aci	"                                        "
	aci	"                                        "
	aci	"                                        "
	aci	"                                                "

	even
hi_random:
	oct	0		These are two words to store the random numbers
				"between calls to the function random.
lo_random:
	oct	0

iochan_list:  its  -1,1

subr_block_list:  its -1,1	list of all subr blocks
binding_reversal_flag:  oct  0		nonzero means can't interrupt because reversing a binding block
evalhook_status:  oct 0			see lisp_
	even
maknum_data:
maknum_table_ptr:	its	-1,1
maknum_next:	oct	0
maknum_mask:	dec	-1
maknum_left:	oct	0

cleanup_list_exists:oct	0		1 => cleanup_list non-nil
"					(needed since might be in gc and can't look at it)
activate_gc_unwinder_kludge: oct 0		flag that gc should do cleanup kludge
mulquit_state:	dec	-1		handling of Multics quit condition
mulpi_state:	dec	-1		handling of Multics program_interrupt condition
deferred_interrupt: oct	0		we must poll interrupts when we leave (nointerrupt t)
	even

pending_ctrl:
	oct	0		"1"b when in process of handling stacked-up
				"ctrl chars received while masked = 1.

ignore_faults:
	dec	0

	even

cur_stat_seg: its -1,1		current static seg, used by make_lisp_subr_block_
cur_stat_pos: dec 0		height in seg that has been allocated

	even
stack_ptr:
	its	-1,1,n		stack_ptr
unmkd_ptr: its	-1,1,n

frame_ptrs:			"since programs think this is an array.  binding_top _m_u_s_t be first.

binding_top:
	its	-1,1,n
err_recp:	its	-1,1
prog_frame:
	its -1,1

err_frame:its -1,1
catch_frame:
	its -1,1
eval_frame:
	its	-1,1
unwp_frame:
	its	-1,1
arg_list_ptr:
	its	-1,1

top_level:
	its	-1,1		a pl1 label is two pointers
	its 	-1,1

argatom:	oct	0,0	double word zero for eval, arg....

gc_unwinder_kludge:  its  -1,1	target of unwindage through in-progress gc,
	its -1,1		has to be saved while gc is completed if cleanup list exists
"
""" Template for initialization of some of the above data

	use	tx
	join	/text/tx

	even
template:
	its	-1,1		cclist ptr
	dec	0		garbage_collect_soon
	oct	0		quit_handler_flag
	even
	dec	0,0		gc_time
	oct	525252000000	gc_mark_bits

	dec	0.5		gcmin
	oct	400000000000	gcmin_fraction
	dec	30000		gcsize
	dec	1000000000	gcmax
	oct	0		no_snapped_links

	oct	0		transparent
	dec	0		read_print_nl_sync
	oct	0		garbage_collect_inhibit
	oct	0		masked
	dec	-1		emptying_buffers
	oct	0		i_am_gcing
	dec	0		rdr_state
	even
	its	-1,1		rdr_ptr
	its	-1,1		rdr_label
	its	-1,1		..
"				saved_environment_dir
	aci	"                                        "
	aci	"                                        "
	aci	"                                        "
	aci	"                                                "
	oct	0		hi_random
	oct	0		lo_random
	its	-1,1		iochan_list
	its	-1,1		subr_block_list
	oct	0		binding_reversal_flag
	oct	0		evalhook_status
	even
	its	-1,1		maknum_table_ptr
	oct	0
	dec	-1
	oct	0
	oct	0		cleanup_list_exists
	oct	0		activate_gc_unwinder_kludge
	dec	-1		mulquit_state
	dec	-1		mulpi_state
""" End of template

template_size:
	zero	0,template_size-template
	use	lk
"
garbage_collected_ptrs:

first_value_atom:
obarray:	its	-1,1


" the following  is a table of pointers to atoms, which are needed as constants
" by various system subrs.  The pointers are inited by lisp_boot_ using
" the table of names which appears below. These atom pointers are preserved
" through a save/unsave.

atomic_constants:

nil:	its	-1,1,n

t_atom:	its	-1,1,n		pointer to atom t.

external:	its	-1,1	the atom "external"

ctrlD:	its	-1,1

ctrlQ:	its	-1,1

ctrlR:	its	-1,1

ctrlW:	its	-1,1

	its	-1,1		interrupt channel 0. (CTRL/@)

user_intr_array:		"pointers to atoms whose values are user interrupt service functions
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
	its	-1,1
STAR:	its	-1,1
PLUS:	its	-1,1

base:	its	-1,1

ibase:	its	-1,1

readtable: its	-1,1

stnopoint:its	-1,1

tty_atom:	its	-1,1


errlist:	its	-1,1	atom errlist, value used by errors.


infile:	its	-1,1
instack:	its	-1,1

outfiles:	its	-1,1

zunderflow: its	-1,1
uread_atom:	its	-1,1
uwrite_atom:	its	-1,1
old_io_defaults: its	-1,1


ctrlA:	its	-1,1

star_rset: its	-1,1	now -> the atom *rset

prinlevel:
	its	-1,1
prinlength:
	its	-1,1

last_value_atom:


value_atom:	its	-1,1

readeof_atom: 	its	-1,1

s_atom:	its	-1,1

dollar_p_atom:
	its	-1,1

quote_atom: its	-1,1			points to the atom quote


pname_atom:	its	-1,1
string_atom:	its	-1,1

fixnum:
fixnum_atom:	its	-1,1

flonum:
flonum_atom:	its	-1,1

random_atom:	its	-1,1

bignum_atom:	its	-1,1

list_atom:	its	-1,1

" constants needed by lisp_error_

go_atom:	its	-1,1
return_atom:
	its	-1,1
pdlframe_atom:
	its	-1,1
alphalessp_atom:
	its	-1,1

"constants needed by the evaluator

lambda:	its	-1,1
label:	its	-1,1
funarg:	its	-1,1
function_properties:
subr:	its	-1,1
lsubr:	its	-1,1
fsubr:	its	-1,1
expr:	its	-1,1
fexpr:	its	-1,1
array:
array_atom:
	its	-1,1,n		atom "array"
macro:	its	-1,1
autoload:	its	-1,1
quotient:	its	-1,1		fail-act name
qarg:	its	-1,1
qsetarg:	its	-1,1
qlstfy:	its	-1,1

evalframe_atom:
	its	-1,1	atom evalframe, which is another name for pdlframe (used by that fcn)

arrayindex: its	-1,1

setq_atom: its	-1,1

question_mark:
	its	-1,1	the atom ?, used by array access error handler


nouuo_flag: its	-1,1

noret_flag: its	-1,1


space_names_atom:			"value=(list markedpdl unmarkedpdl)
quote_macro:			"used as indicator for quote macro char
	its	-1,1

semicolon_macro:			"indicator for semicolon macro char + value = (status features)
	its	-1,1


runtime_atom:
	its	-1,1
time_atom:
	its	-1,1

comment_atom:
	its	-1,1
declare_atom:
	its	-1,1

" atomic constants needed by the new I/O system.


close:	its	-1,1
deletef:	its	-1,1
filepos:	its	-1,1
mergef:	its	-1,1
open:	its	-1,1
cruft1:	its	-1,1		used to be openi
evalhook_atom:  its  -1,1		used to be openo, now is 'evalhook (nothing to do with I/O)
outfile:	its	-1,1
rename:	its	-1,1
stream:	its	-1,1

"  atomic constants needed by status   &   sstatus for  new  I/O  system


dsk_atom:	its	-1,1

crunit_atom:	its	-1,1

args:	its	-1,1

	" atomic constants needed by lisp_error_

err_atom:	its	-1,1

eval_atom: its	-1,1

apply_atom: its	-1,1

princ_atom: its	-1,1

prin1:
prin1_atom: its	-1,1

print_atom: its	-1,1
MINUS:	its	-1,1
SLASH:	its	-1,1
defun:	its	-1,1
expr_hash:its	-1,1
vertical_bar_macro:
	its 	-1,1
eof_atom: its	-1,1
progn_atom:
	its	-1,1

end_atomic_constants:


toplevel:	its	-1,1
divov_flag:	its -1,1			(status divov) - t means handle divide overflow
plus_status:
	its	-1,1


status_gctwa:	its	-1,1
tty_input_chan:
	its	-1,1

tty_output_chan:
	its	-1,1

property_list_of_nil:
	its	-1,1
cleanup_list:
	its	-1,1
end_gc_area: null
"
	use	tx
"	join	/text/tx		put this unchanging stuff in the text section

number_gc_ptrs:
	zero	0,(end_gc_area-garbage_collected_ptrs)/2
number_of_atomic_constants:
	zero	0,(end_atomic_constants-atomic_constants)/2

subsys_recurse_save_size:
	zero	0,end_gc_area-lisp_static_vars_




" table of names of atomic constants above.
" in acc format. There is no maximum name length, the names
" are simply concatenated.

atomic_constants_names:
	acc	/nil/
	acc	/t/
	acc	/external/
	acc	/^d/
	acc	/^q/
	acc	/^r/
	acc	/^w/
	acc	/internal_interrupt_0_atom_/
	acc	/^b/			user_intr_array(1)
	acc	/internal_interrupt_2_atom_/
	acc	/alarmclock/
	acc	/errset/
	acc	/undf-fnctn/
	acc	/unbnd-vrbl/
	acc	/wrng-type-arg/
	acc	/unseen-go-tag/
	acc	/wrng-no-args/
	acc	/gc-lossage/
	acc	/fail-act/
	acc	/pdl-overflow/
	acc	/nil/
	acc	/internal_interrupt_14_atom_/
	acc	/internal_interrupt_15_atom_/
	acc	/internal_interrupt_16_atom_/
	acc	/nil/
	acc	/internal_autoload_atom_/
	acc	/*rset-trap/
	acc	/gc-daemon/
	acc	/*/
	acc	/+/
	acc	/base/
	acc	/ibase/
	acc	/readtable/
	acc	/*nopoint/
	acc	/tty/
	acc	/errlist/
	acc	/infile/
	acc	/instack/
	acc	/outfiles/
	acc	/zunderflow/
	acc	/uread/
	acc	/uwrite/
	acc	/old-io-defaults/
	acc	/^a/
	acc	/*rset/
	acc	/prinlevel/
	acc	/prinlength/
	acc	/value/
	acc	/read-eof/
	acc	/splicing/
	acc	/$p/
	acc	/quote/
	acc	/symbol/
	acc	/string/
	acc	/fixnum/
	acc	/flonum/
	acc	/random/
	acc	/bignum/
	acc	/list/
	acc	/go/
	acc	/return/
	acc	/pdlframe/
	acc	/alphalessp/
	acc	/lambda/
	acc	/label/
	acc	/funarg/
	acc	/subr/
	acc	/lsubr/
	acc	/fsubr/
	acc	/expr/
	acc	/fexpr/
	acc	/array/
	acc	/macro/
	acc	/autoload/
	acc	/quotient/
	acc	/arg/
	acc	/setarg/
	acc	/listify/
	acc	/evalframe/
	acc	/arrayindex/
	acc	/setq/
	acc	/?/
	acc	/nouuo/		nouuo flag = global var
	acc	/noret/		noret flag = global var
	acc	/internal_quote_macro_/
	acc	/internal_semicolon_macro_/
	acc	/runtime/
	acc	/time/
	acc	/comment/	atom for comment subr to return
	acc	/declare/ atom for declare subr to return.
	acc	/close/
	acc	/deletef/
	acc	/filepos/
	acc	/mergef/
	acc	/open/
	acc	/cruft1../	used to be openi
	acc	/evalhook/	used to be openo...
	acc	/outfile/
	acc	/rename/
	acc	/stream/
	acc	/dsk/
	acc	/crunit/
	acc	/args/
	acc	/err/
	acc	/eval/
	acc	/apply/
	acc	/princ/
	acc	/prin1/
	acc	/print/
	acc	/-/
	acc	|/|
	acc	/defun/
	acc	/expr-hash/
	acc	/internal_vertical_bar_macro_/
	acc	/eof/
	acc	/progn/
	end




		    lisp_subr_tv_.alm               11/05/86  1612.7r w 11/04/86  1039.2      258678



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
	name	lisp_subr_tv_

"	This segment of lisp is used to allow pointers from the
"	lisp environment, which is impure, to reference lisp subroutines.
"	It is a transfer vector, in which each entry is comprised of four
"	words -- a header word containing information about the subroutine,
"	one or two words of code, and a word which gives information to the
"	bootstrapping routine which generates the initial lisp environment.
"	It is important that modifications to this segment not change
"	the positions of the unchanged subroutine entry points, so that
"	a change or addition to the subroutines supported by lisp
"	does not have to invalidate the contents of previously generated saved
"	environments.
"
"	Three types of subroutine calls are handled here...the fast call
"	is just a transfer to the real entry point...see for example the subroutine
"	"cdr". The normal call is done by a tsx6 to the type_1_subr routine
"	which saves the return address and lp on the unmarked stack,
"	and then a transfer to the routine.  PL/I subroutines
"	are called by going through an interface routine...either pl1_fixup or
"	pl1_lsubr_fixup is used depending on the type of the subr.
"
"	It is important to realize that this segment will not work correctly if
"	not bound with the other alm modules in the lisp system.  It depends on the
"	two facts that:
"	     a) the binder coalesces the linkage sections of all of the
"	        component segments when binding, so that ab|system_lp,
"	        which is saved at entry to lisp, works for all alm modules
"	        which require a pointer to their linkage section.
"	     b) transfers to fast call subroutines will be altered by the linker
"	        to direct transfers, rather than going through links, so that
"	        lp need not be set at the time of the transfer.
"
"
"	History:
"	     First modified by D. Reed, who generated it from the segment lisp_standard_environment_.ec,
"		on 2/19/73.
" Modified 3/13/72 by DAM for New I/O Functions
" Modified 17 Apr 1974 by DAM to add error-break fcns (formerly in lisp_standard_environment_.ec)
" ***** the name of the second location counter was changed from names
" ***** to Names due to a name clash.
" Modified 74.12.16 by DAM.  The transfer vector is now compiled from a readable,
"	symbolic source file called lisp_subr_tv_.macro into lisp_subr_tv_.incl.alm.
"	This file contains the necessary declarations and support routines.
" Modified 1982.10.04 by Richard Lamson to convert into ALM, now that it has
"				macros, rather than converting from the
"				kludgiferous lisp_subr_tv_.macro

	equ	subr,0
	equ	lsubr,1
	equ	fsubr,2

	segdef	tv_begin
	segdef	lisp_subr_tv_
	segdef	tv_entry_count

	use	tv
tv_entry_count:	zero	0,(tv_end-tv_begin)/4-1
	even		" must be even, else garbage collection and saving don't work right.

	macro	type_0_subr
	use 	tv
		vfd	9/&4,9/&3,18/-1
		tra	&5
		zero
		zero	&U-lisp_subr_tv_,&1
	use 	Names
&U:		acc	"&2"
	use	tv
	&end

	macro	type_1_subr
	use	tv
		vfd	9/&4,9/&3,18/-1
		tsx6	type_1_subr
		tra	&5
		zero	&U-lisp_subr_tv_,&1
	use	Names
&U:		acc	"&2"
	use	tv
	&end

	macro	pl1
	use	tv
		vfd	9/&4,9/&3,18/-1
		tsx6	pl1_fixup
		tra	&5
		zero	&U-lisp_subr_tv_,&1
	use	Names
&U:		acc	"&2"
	use	tv
	&end
		
	macro	pl1_lsubr
	use	tv
		vfd	9/&4,9/&3,18/-1
		tsx6	pl1_lsubr_fixup
		tra	&5
		zero	&U-lisp_subr_tv_,&1
	use	Names
&U:		acc	"&2"
	use	tv
	&end

	macro	err_break
	use	tv
		vfd	9/0,9/1,18/-1
		tsx6	err_break-*,ic
		zero	&3,&4
		zero	&U-lisp_subr_tv_,&1
	use	Names
&U:		acc	"&2"
	use	tv
	&end

	macro	none_such
	use	tv
		zero 0,-1
		drl	0
		zero
		zero	&U-lisp_subr_tv_,&1
	use	Names
&U:		acc	"&2"
	use	tv
	&end

tv_begin:	null
lisp_subr_tv_: null

star_flt:		type_0_subr   lsubr,*$,0,511,lisp_utils_$times_flo
star_:		type_0_subr   lsubr,*,0,511,lisp_utils_$times_fix
star_array:	pl1_lsubr	    lsubr,*array,3,511,lisp_array_fcns_$star_array
star_dif:		type_1_subr   lsubr,*dif,2,2,lisp_bignums_$difference
star_function:	type_1_subr   fsubr,*function,,,lisp_$stfunction
star_quo:		type_1_subr   lsubr,*quo,2,2,lisp_bignums_$quotient
star_rearray:	pl1_lsubr	    lsubr,*rearray,1,511,lisp_array_fcns_$star_rearray
star_rset:	pl1	     subr,*rset,1,,lisp_status_fns_$rset
star_sstatus:	pl1_lsubr	    lsubr,*sstatus,1,511,lisp_status_fns_$sstatus_
star_status:	pl1_lsubr	    lsubr,*status,1,511,lisp_status_fns_$status_
pls_flt:		type_0_subr   lsubr,+$,0,511,lisp_utils_$plus_flo
pls_:		type_0_subr   lsubr,+,0,511,lisp_utils_$plus_fix
mns_flt:		type_0_subr   lsubr,-$,0,511,lisp_utils_$diff_flo
mns_:		type_0_subr   lsubr,-,0,511,lisp_utils_$diff_fix
div_flt:		type_0_subr   lsubr,/$,0,511,lisp_utils_$quot_flo
div_:		type_0_subr   lsubr,/,0,511,lisp_utils_$quot_fix
one_pls_flt:	type_0_subr    subr,1+$,1,,lisp_utils_$add1_flo
one_pls:		type_0_subr    subr,1+,1,,lisp_utils_$add1_fix
one_mns_flt:	type_0_subr    subr,1-$,1,,lisp_utils_$sub1_flo
one_mns:		type_0_subr    subr,1-,1,,lisp_utils_$sub1_fix
ls_:		type_0_subr    subr,<,2,,lisp_utils_$ls_
eqn_:		type_0_subr    subr,=,2,,lisp_utils_$eql_
gt_:		type_0_subr    subr,>,2,,lisp_utils_$gt_
CtoI:		pl1	     subr,CtoI,1,,lisp_char_fns_$CtoI
ItoC:		pl1	     subr,ItoC,1,,lisp_char_fns_$ItoC
rem_:		type_1_subr    subr,\,2,,lisp_bignums_$remainder
abs:		type_1_subr    subr,abs,1,,lisp_bignums_$abs
add1:		type_1_subr    subr,add1,1,,lisp_bignums_$add1
alarmclock:	pl1	     subr,alarmclock,2,,lisp_fault_handler_$alarmclock
allfiles:		pl1	     subr,allfiles,1,,lisp_io_fns_$allfiles
and:		type_1_subr   fsubr,and,,,lisp_quick_fcns_$and
append:		type_1_subr   lsubr,append,0,511,lisp_alloc_$append
apply:		type_1_subr   lsubr,apply,2,3,lisp_$apply_
arg:		type_1_subr    subr,arg,1,,lisp_$arg
args:		pl1_lsubr	    lsubr,args,1,2,lisp_defsubr_$args
array:		pl1	    fsubr,array,,,lisp_array_fcns_$array
arraydims:	pl1	     subr,arraydims,1,,lisp_array_fcns_$arraydims
ascii:		type_1_subr    subr,ascii,1,,lisp_reader_alm_$ascii_alm
assoc:		type_0_subr    subr,assoc,2,,lisp_quick_fcns_$assoc
assq:		type_0_subr    subr,assq,2,,lisp_quick_fcns_$assq
atan:		pl1_lsubr	    lsubr,atan,1,2,lisp_trig_$atan
atom:		type_0_subr    subr,atom,1,,lisp_quick_fcns_$atom
baktrace1:	pl1_lsubr	    lsubr,baktrace1,0,2,lisp_baktrace_$baktrace1
baktrace2:	pl1_lsubr	    lsubr,baktrace2,0,2,lisp_baktrace_$baktrace2
baktrace:		pl1_lsubr	    lsubr,baktrace,0,2,lisp_baktrace_$baktrace
bigp:		type_0_subr    subr,bigp,1,,lisp_quick_fcns_$bigp
bltarray:		pl1	     subr,bltarray,2,,lisp_array_fcns_$bltarray
boole:		type_0_subr   lsubr,boole,3,511,lisp_utils_$boole
boundp:		type_1_subr    subr,boundp,1,,lisp_alloc_$boundp
break:		pl1	    fsubr,break,,,lisp_prog_fns_$break
caaaar:		type_1_subr    subr,caaaar,1,,lisp_car_cdrs_$caaaar
caaadr:		type_1_subr    subr,caaadr,1,,lisp_car_cdrs_$caaadr
caaar:		type_1_subr    subr,caaar,1,,lisp_car_cdrs_$caaar
caadar:		type_1_subr    subr,caadar,1,,lisp_car_cdrs_$caadar
caaddr:		type_1_subr    subr,caaddr,1,,lisp_car_cdrs_$caaddr
caadr:		type_1_subr    subr,caadr,1,,lisp_car_cdrs_$caadr
caar:		type_1_subr    subr,caar,1,,lisp_car_cdrs_$caar
cadaar:		type_1_subr    subr,cadaar,1,,lisp_car_cdrs_$cadaar
cadadr:		type_1_subr    subr,cadadr,1,,lisp_car_cdrs_$cadadr
cadar:		type_1_subr    subr,cadar,1,,lisp_car_cdrs_$cadar
caddar:		type_1_subr    subr,caddar,1,,lisp_car_cdrs_$caddar
cadddr:		type_1_subr    subr,cadddr,1,,lisp_car_cdrs_$cadddr
caddr:		type_1_subr    subr,caddr,1,,lisp_car_cdrs_$caddr
cadr:		type_1_subr    subr,cadr,1,,lisp_car_cdrs_$cadr
car:		type_0_subr    subr,car,1,,lisp_car_cdrs_$car
catch:		pl1	    fsubr,catch,,,lisp_prog_fns_$catch
catenate:		pl1_lsubr	    lsubr,catenate,0,511,lisp_char_fns_$catenate
cdaaar:		type_1_subr    subr,cdaaar,1,,lisp_car_cdrs_$cdaaar
cdaadr:		type_1_subr    subr,cdaadr,1,,lisp_car_cdrs_$cdaadr
cdaar:		type_1_subr    subr,cdaar,1,,lisp_car_cdrs_$cdaar
cdadar:		type_1_subr    subr,cdadar,1,,lisp_car_cdrs_$cdadar
cdaddr:		type_1_subr    subr,cdaddr,1,,lisp_car_cdrs_$cdaddr
cdadr:		type_1_subr    subr,cdadr,1,,lisp_car_cdrs_$cdadr
cdar:		type_1_subr    subr,cdar,1,,lisp_car_cdrs_$cdar
cddaar:		type_1_subr    subr,cddaar,1,,lisp_car_cdrs_$cddaar
cddadr:		type_1_subr    subr,cddadr,1,,lisp_car_cdrs_$cddadr
cddar:		type_1_subr    subr,cddar,1,,lisp_car_cdrs_$cddar
cdddar:		type_1_subr    subr,cdddar,1,,lisp_car_cdrs_$cdddar
cddddr:		type_1_subr    subr,cddddr,1,,lisp_car_cdrs_$cddddr
cdddr:		type_1_subr    subr,cdddr,1,,lisp_car_cdrs_$cdddr
cddr:		type_1_subr    subr,cddr,1,,lisp_car_cdrs_$cddr
cdr:		type_0_subr    subr,cdr,1,,lisp_car_cdrs_$cdr
chrct:		type_0_subr   lsubr,chrct,1,2,lisp_reader_alm_$chrct
cline:		pl1	     subr,cline,1,,lisp_command_caller_$cline
close:		pl1	     subr,close,1,,lisp_io_control_$close
comment:		type_1_subr   fsubr,comment,,,lisp_quick_fcns_$comment
cond:		type_1_subr   fsubr,cond,,,lisp_quick_fcns_$cond
cons:		type_1_subr    subr,cons,2,,lisp_alloc_$cons_
cos:		pl1	     subr,cos,1,,lisp_trig_$cos
declare:		type_1_subr   fsubr,declare,,,lisp_quick_fcns_$declare
definedp:		type_1_subr    subr,definedp,1,,lisp_alloc_$boundp
defprop:		pl1	    fsubr,defprop,,,lisp_define_$defprop
defsubr:		pl1_lsubr	    lsubr,defsubr,3,7,lisp_defsubr_$defsubr
defun:		pl1	    fsubr,defun,,,lisp_define_$defun
delete:		type_1_subr   lsubr,delete,2,3,lisp_quick_fcns_$delete
deletef:		pl1	     subr,deletef,1,,lisp_io_control_$deletef
delq:		type_1_subr   lsubr,delq,2,3,lisp_quick_fcns_$delq
difference:	type_1_subr   lsubr,difference,1,511,lisp_bignums_$difference
do:		pl1	    fsubr,do,,,lisp_prog_fns_$do
eoffn:		pl1_lsubr	    lsubr,eoffn,1,2,lisp_io_fns_$eoffn
eq:		type_0_subr    subr,eq,2,,lisp_quick_fcns_$eq
equal:		type_0_subr    subr,equal,2,,lisp_quick_fcns_$equal
err:		pl1	    fsubr,err,,,lisp_error_$err
errframe:		pl1	     subr,errframe,1,,lisp_error_$errframe
errprint:		pl1	     subr,errprint,1,,lisp_error_$errprint
errset:		pl1	    fsubr,errset,,,lisp_prog_fns_$errset
eval:		type_1_subr   lsubr,eval,1,2,lisp_$eval_
evalframe:	pl1	     subr,evalframe,1,,lisp_error_$pdlframe
exp:		pl1	     subr,exp,1,,lisp_trig_$exp
explode:		pl1	     subr,explode,1,,lisp_print_$explode
explodec:		pl1	     subr,explodec,1,,lisp_print_$explodec
exploden:		pl1	     subr,exploden,1,,lisp_print_$exploden
expt:		type_1_subr    subr,expt,2,,lisp_bignums_$expt
filepos:		pl1_lsubr	    lsubr,filepos,1,2,lisp_io_fns_$filepos
fix:		type_1_subr    subr,fix,1,,lisp_bignums_$fix
fixp:		type_0_subr    subr,fixp,1,,lisp_quick_fcns_$fixp
flatc:		pl1	     subr,flatc,1,,lisp_print_$flatc
flatsize:		pl1	     subr,flatsize,1,,lisp_print_$flatsize
float:		type_1_subr    subr,float,1,,lisp_bignums_$float
floatp:		type_0_subr    subr,floatp,1,,lisp_quick_fcns_$floatp
freturn:		pl1	     subr,freturn,2,,lisp_error_$freturn
function:		type_0_subr   fsubr,function,,,lisp_car_cdrs_$quote
gc:		pl1	     subr,gc,0,,lisp_garbage_collector_$gcsubr
gctwa:		pl1	    fsubr,gctwa,,,lisp_status_fns_$gctwa
gensym:		type_1_subr   lsubr,gensym,0,1,lisp_alloc_$gensym_
get:		type_1_subr    subr,get,2,,lisp_property_fns_$get_
get_pname:	pl1	     subr,get_pname,1,,lisp_char_fns_$get_pname
getl:		type_1_subr    subr,getl,2,,lisp_property_fns_$getl_
go:		type_1_subr   fsubr,go,,,lisp_$go
greaterp:		type_1_subr   lsubr,greaterp,1,511,lisp_bignums_$greaterp
index:		pl1	     subr,index,2,,lisp_char_fns_$Index
inpush:		pl1	     subr,inpush,1,,lisp_io_fns_$inpush
intern:		pl1	     subr,intern,1,,lisp_obarray_utils_$intern
ioc:		pl1	    fsubr,ioc,,,lisp_fault_handler_$ioc
iog:		pl1	    fsubr,iog,,,lisp_fault_handler_$iog
isqrt:		pl1	     subr,isqrt,1,,lisp_trig_$isqrt
last:		type_0_subr    subr,last,1,,lisp_quick_fcns_$last
length:		type_0_subr    subr,length,1,,lisp_quick_fcns_$length
lessp:		type_1_subr   lsubr,lessp,1,511,lisp_bignums_$lessp
linel:		type_0_subr   lsubr,linel,1,2,lisp_reader_alm_$linel
list:		type_1_subr   lsubr,list,0,511,lisp_alloc_$list_
log:		pl1	     subr,log,1,,lisp_trig_$log
lsh:		type_0_subr    subr,lsh,2,,lisp_utils_$lsh
make_atom:	pl1	     subr,make_atom,1,,lisp_char_fns_$make_atom
maknam:		pl1	     subr,maknam,1,,lisp_reader_$maknam
makoblist:	pl1	     subr,makoblist,1,,lisp_obarray_utils_$makoblist
makreadtable:	pl1	     subr,makreadtable,1,,lisp_reader_$makreadtable
makunbound:	type_1_subr    subr,makunbound,1,,lisp_alloc_$makunbound
map:		type_1_subr   lsubr,map,2,511,lisp_$map
mapc:		type_1_subr   lsubr,mapc,2,511,lisp_$mapc
mapcan:		type_1_subr   lsubr,mapcan,2,511,lisp_$mapcan
mapcar:		type_1_subr   lsubr,mapcar,2,511,lisp_$mapcar
mapcon:		type_1_subr   lsubr,mapcon,2,511,lisp_$mapcon
maplist:		type_1_subr   lsubr,maplist,2,511,lisp_$maplist
max:		type_1_subr   lsubr,max,1,511,lisp_bignums_$max
member:		type_0_subr    subr,member,2,,lisp_quick_fcns_$member
memq:		type_0_subr    subr,memq,2,,lisp_quick_fcns_$memq
min:		type_1_subr   lsubr,min,1,511,lisp_bignums_$min
minus:		type_1_subr    subr,minus,1,,lisp_bignums_$minus
minusp:		type_1_subr    subr,minusp,1,,lisp_bignums_$minusp
mergef:		pl1_lsubr	    lsubr,mergef,2,511,lisp_io_control_$mergef
nconc:		type_1_subr   lsubr,nconc,0,511,lisp_alloc_$nconc
ncons:		type_1_subr    subr,ncons,1,,lisp_alloc_$ncons_
namelist:		pl1	     subr,namelist,1,,lisp_io_fns_$namelist
names:		pl1_lsubr	    lsubr,names,1,2,lisp_io_fns_$names
namestring:	pl1	     subr,namestring,1,,lisp_io_fns_$namestring
nointerrupt:	pl1	     subr,nointerrupt,1,,lisp_fault_handler_$nointerrupt
noret:		pl1	     subr,noret,1,,lisp_status_fns_$noret
not:		type_0_subr    subr,not,1,,lisp_quick_fcns_$null
nouuo:		type_1_subr    subr,nouuo,1,,lisp_$nouuo
nreverse:		type_1_subr    subr,nreverse,1,,lisp_alloc_$nreverse_
null:		type_0_subr    subr,null,1,,lisp_quick_fcns_$null
numberp:		type_0_subr    subr,numberp,1,,lisp_quick_fcns_$numberp
oddp:		type_0_subr    subr,oddp,1,,lisp_quick_fcns_$oddp
opena:		pl1	     subr,opena,1,,lisp_io_control_$opena
openi:		pl1	     subr,openi,1,,lisp_io_control_$openi
openo:		pl1	     subr,openo,1,,lisp_io_control_$openo
or:		type_1_subr   fsubr,or,,,lisp_quick_fcns_$or
plus:		type_1_subr   lsubr,plus,0,511,lisp_bignums_$plus
plusp:		type_1_subr    subr,plusp,1,,lisp_bignums_$plusp
prin1:		pl1_lsubr	    lsubr,prin1,1,2,lisp_print_$prin1_
princ:		pl1_lsubr	    lsubr,princ,1,2,lisp_print_$princ_
print:		pl1_lsubr	    lsubr,print,1,2,lisp_print_$print_
prog2:		type_0_subr   lsubr,prog2,2,511,lisp_quick_fcns_$prog2
prog:		pl1	    fsubr,prog,,,lisp_prog_fns_$prog
progn:		type_0_subr   lsubr,progn,1,511,lisp_quick_fcns_$progn
putprop:		type_1_subr    subr,putprop,3,,lisp_property_fns_$putprop_
quit:		pl1	     subr,quit,0,,lisp$quit
quote:		type_0_subr   fsubr,quote,,,lisp_car_cdrs_$quote
quotient:		type_1_subr   lsubr,quotient,1,511,lisp_bignums_$quotient
random:		type_1_subr   lsubr,random,0,1,lisp_quick_fcns_$random
read:		pl1_lsubr	    lsubr,read,0,2,lisp_reader_$read
readch:		type_1_subr   lsubr,readch,0,2,lisp_reader_alm_$readch
readlist:		pl1	     subr,readlist,1,,lisp_reader_$readlist
readline:		pl1_lsubr	    lsubr,readline,0,2,lisp_reader_$readstring
remainder:	type_1_subr    subr,remainder,2,,lisp_bignums_$remainder
remob:		pl1	     subr,remob,1,,lisp_obarray_utils_$remob
remprop:		type_1_subr    subr,remprop,2,,lisp_property_fns_$remprop_
rename:		pl1	     subr,rename,2,,lisp_io_control_$rename
return:		type_1_subr    subr,return,1,,lisp_$return
reverse:		type_1_subr    subr,reverse,1,,lisp_alloc_$reverse
rot:		type_0_subr    subr,rot,2,,lisp_utils_$rot
rplaca:		type_1_subr    subr,rplaca,2,,lisp_quick_fcns_$rplaca
rplacd:		type_0_subr    subr,rplacd,2,,lisp_quick_fcns_$rplacd
runtime:		type_0_subr    subr,runtime,0,,lisp_quick_fcns_$runtime
sassoc:		type_0_subr    subr,sassoc,3,,lisp_quick_fcns_$sassoc
sassq:		type_0_subr    subr,sassq,3,,lisp_quick_fcns_$sassq
save:		pl1	    fsubr,save,,,lisp$save
set:		type_1_subr    subr,set,2,,lisp_quick_fcns_$set
setarg:		type_1_subr    subr,setarg,2,,lisp_$setarg
setq:		type_1_subr   fsubr,setq,,,lisp_quick_fcns_$setq
shortnamestring:	pl1	     subr,shortnamestring,1,,lisp_io_fns_$shortnamestring
signp:		type_1_subr   fsubr,signp,,,lisp_utils_$signp
sin:		pl1	     subr,sin,1,,lisp_trig_$sin
sleep:		pl1	     subr,sleep,1,,lisp_trig_$sleep
smallnump:	type_0_subr    subr,smallnump,1,,lisp_quick_fcns_$smallnump
sqrt:		pl1	     subr,sqrt,1,,lisp_trig_$sqrt
sstatus:		pl1	    fsubr,sstatus,,,lisp_status_fns_$sstatus
status:		pl1	    fsubr,status,,,lisp_status_fns_$status
store:		type_1_subr   fsubr,store,,,lisp_oprs_$store
stringlength:	pl1	     subr,stringlength,1,,lisp_char_fns_$stringlength
stringp:		type_0_subr    subr,stringp,1,,lisp_quick_fcns_$stringp
sub1:		type_1_subr    subr,sub1,1,,lisp_bignums_$sub1
sublis:		type_1_subr    subr,sublis,2,,lisp_alloc_$sublis
subrp:		type_0_subr    subr,subrp,1,,lisp_quick_fcns_$subrp
subst:		type_1_subr    subr,subst,3,,lisp_alloc_$subst_
substr2:		pl1	     subr,substr2,2,,lisp_char_fns_$Substr2
substr:		pl1_lsubr	    lsubr,substr,2,3,lisp_char_fns_$Substr
sysp:		pl1	     subr,sysp,1,,lisp_defsubr_$sysp
terpri:		pl1_lsubr	    lsubr,terpri,0,1,lisp_print_$terpri
throw:		pl1	    fsubr,throw,,,lisp_prog_fns_$throw
time:		pl1	     subr,time,0,,lisp_status_fns_$time
times:		type_1_subr   lsubr,times,0,511,lisp_bignums_$times
tyi:		type_1_subr   lsubr,tyi,0,2,lisp_reader_alm_$tyi
tyipeek:		type_1_subr   lsubr,tyipeek,0,2,lisp_reader_alm_$tyipeek
tyo:		type_1_subr   lsubr,tyo,1,2,lisp_reader_alm_$tyo_alm
typep:		type_1_subr    subr,typep,1,,lisp_utils_$typep
xcons:		type_1_subr    subr,xcons,2,,lisp_alloc_$xcons_
zerop:		type_0_subr    subr,zerop,1,,lisp_quick_fcns_$zerop
alphalessp:	type_1_subr    subr,alphalessp,2,,lisp_quick_fcns_$alphalessp
samepnamep:	type_1_subr    subr,samepnamep,2,,lisp_quick_fcns_$samepnamep
getchar:		type_1_subr    subr,getchar,2,,lisp_quick_fcns_$getchar
sxhash:		type_1_subr    subr,sxhash,1,,lisp_utils_$sxhash
gcd:		type_1_subr    subr,gcd,2,,lisp_bignums_$gcd
error:		pl1_lsubr	    lsubr,error,0,3,lisp_error_$error
setsyntax:	pl1	     subr,setsyntax,3,,lisp_status_fns_$setsyntax
cursorpos:	pl1_lsubr	    lsubr,cursorpos,0,3,lisp_io_fns_$cursorpos
force_output:	pl1	     subr,force-output,1,,lisp_io_control_$force_output
clear_input:	pl1	     subr,clear-input,1,,lisp_io_control_$clear_input
haipart:		type_1_subr    subr,haipart,2,,lisp_bignums_$haipart
haulong:		type_1_subr    subr,haulong,1,,lisp_bignums_$haulong
sort:		pl1	     subr,sort,2,,lisp_array_fcns_$sort
sortcar:		pl1	     subr,sortcar,2,,lisp_array_fcns_$sortcar
fillarray:	pl1	     subr,fillarray,2,,lisp_array_fcns_$fillarray
listarray:	pl1_lsubr	    lsubr,listarray,1,2,lisp_array_fcns_$listarray
listify:		type_1_subr    subr,listify,1,,lisp_$listify
quikload:		none_such	     ,listen
funcall:		type_1_subr   lsubr,funcall,1,511,lisp_$funcall
listen:		type_1_subr    subr,listen,0,,lisp_reader_alm_$listen
fixgcd:		type_0_subr    subr,\\,2,,lisp_utils_$fixgcd
copysymbol:	type_1_subr    subr,copysymbol,2,,lisp_alloc_$copysymbol
load:		pl1	     subr,load,1,,lisp_load_$lisp_load_
charpos:		type_0_subr   lsubr,charpos,1,2,lisp_reader_alm_$charpos
linenum:		type_0_subr   lsubr,linenum,1,2,lisp_reader_alm_$linenum
pagenum:		type_0_subr   lsubr,pagenum,1,2,lisp_reader_alm_$pagenum
pagel:		type_0_subr   lsubr,pagel,1,2,lisp_reader_alm_$pagel
endpagefn:	pl1_lsubr	    lsubr,endpagefn,1,2,lisp_io_fns_$endpagefn
percent_include:	pl1	    fsubr,%include,,,lisp_io_control_$percent_include
defaultf:		pl1	     subr,defaultf,1,,lisp_io_fns_$defaultf
alloc:		pl1	     subr,alloc,1,,lisp_status_fns_$alloc
implode:		pl1	     subr,implode,1,,lisp_reader_$implode
purcopy:		type_0_subr    subr,purcopy,1,,lisp_subr_tv_$purcopy_code
nreconc:		type_1_subr    subr,nreconc,2,,lisp_alloc_$nreconc_
err_1:		err_break	         ,*internal-^b-break,0,0
err_5:		err_break	         ,*internal-undf-fnctn-break,-1,8
err_6:		err_break	         ,*internal-unbnd-vrbl-break,-1,10
err_7:		err_break	         ,*internal-wrng-type-arg-break,-1,12
err_8:		err_break	         ,*internal-unseen-go-tag-break,-1,14
err_9:		err_break	         ,*internal-wrng-no-args-break,-1,16
err_10:		err_break	         ,*internal-gc-lossage-break,0,18
err_11:		err_break	         ,*internal-fail-act-break,-1,20
err_12:		err_break	         ,*internal-pdl-overflow-break,-1,22
err_19:		type_0_subr    subr,*internal-*rset-break,1,,lisp_subr_tv_$star_rset_trap
err_18:		type_0_subr    subr,*internal-autoload-trap,1,,lisp_subr_tv_$autoload_trap
getcharn:		type_1_subr    subr,getcharn,2,,lisp_quick_fcns_$getcharn
subrcall:		type_1_subr   fsubr,subrcall,,,lisp_$subrcall
lsubrcall:	type_1_subr   fsubr,lsubrcall,,,lisp_$lsubrcall
arraycall:	type_1_subr   fsubr,arraycall,,,lisp_$arraycall
maknum:		type_1_subr    subr,maknum,1,,lisp_alloc_$maknum
munkam:		type_1_subr    subr,munkam,1,,lisp_alloc_$munkam
loadarrays:	pl1	     subr,loadarrays,1,,lisp_loadumparrays_$loadarrays
dumparrays:	pl1	     subr,dumparrays,2,,lisp_loadumparrays_$dumparrays
expt_fix:		type_0_subr    subr,^,2,,lisp_utils_$expt_fix
expt_flt:		type_0_subr    subr,^$,2,,lisp_utils_$expt_flo
symeval:		type_1_subr    subr,symeval,1,,lisp_$symeval
plist:		type_1_subr    subr,plist,1,,lisp_property_fns_$plist_
setplist:		type_1_subr    subr,setplist,2,,lisp_property_fns_$setplist_
open:		pl1_lsubr	    lsubr,open,0,2,lisp_io_control_$open
in:		pl1	     subr,in,1,,lisp_io_control_$in
out:		pl1	     subr,out,2,,lisp_io_control_$out
truename:		pl1	     subr,truename,1,,lisp_io_fns_$truename
evalhook:		type_1_subr    subr,evalhook,2,,lisp_$evalhook
fsc:		type_0_subr    subr,fsc,2,,lisp_utils_$fsc
ifix:		type_0_subr    subr,ifix,1,,lisp_utils_$ifix
progv:		pl1	    fsubr,progv,,,lisp_prog_fns_$progv
mapatoms:		pl1_lsubr	    lsubr,mapatoms,1,2,lisp_array_fcns_$mapatoms
symbolp:		type_0_subr    subr,symbolp,1,,lisp_quick_fcns_$symbolp
filep:		type_0_subr    subr,filep,1,,lisp_quick_fcns_$filep
suspend:		pl1	     subr,suspend,0,,lisp_command_caller_$suspend
ctrl_g:		pl1	     subr,^g,0,,lisp_fault_handler_$ctrl_g_function
unwind_protect:	pl1	    fsubr,unwind-protect,,,lisp_prog_fns_$unwind_protect
let:		type_1_subr   fsubr,let,,,lisp_$let
arrayp:		type_0_subr    subr,arrayp,1,,lisp_quick_fcns_$arrayp
list_star:	type_1_subr   lsubr,list*,1,511,lisp_alloc_$list_star_
eval_when:	pl1	    fsubr,eval-when,,,lisp_prog_fns_$eval_when
read_from_string:	pl1	     subr,read-from-string,1,,lisp_reader_$read_from_string
prog1:		type_0_subr   lsubr,prog1,1,511,lisp_quick_fcns_$prog1
displace:		type_1_subr    subr,displace,2,,lisp_quick_fcns_$displace
nth:		type_1_subr    subr,nth,2,,lisp_car_cdrs_$nth
nthcdr:		type_1_subr    subr,nthcdr,2,,lisp_car_cdrs_$nthcdr
first:		type_0_subr    subr,first,1,,lisp_car_cdrs_$car
second:		type_1_subr    subr,second,1,,lisp_car_cdrs_$cadr
third:		type_1_subr    subr,third,1,,lisp_car_cdrs_$caddr
fourth:		type_1_subr    subr,fourth,1,,lisp_car_cdrs_$cadddr
rest1:		type_0_subr    subr,rest1,1,,lisp_car_cdrs_$cdr
rest2:		type_1_subr    subr,rest2,1,,lisp_car_cdrs_$cddr
rest3:		type_1_subr    subr,rest3,1,,lisp_car_cdrs_$cdddr
rest4:		type_1_subr    subr,rest4,1,,lisp_car_cdrs_$cddddr
includef:		pl1	     subr,includef,1,,lisp_io_control_$includef

	use	tv
tv_end:	null

"
"	trap code for unimplemented subrs in a given release
"
	dup	80
	tra	trap_out_unimp
	dupend

trap_out_unimp:
	push	64
trap_out_unimp_1:
	eppap	trap_argl
	short_call	signal_$signal_
	tra	trap_out_unimp_1
	even
trap_argl:zero	4,4
	zero	4,0
	arg	trap_cname
	zero
	arg	trap_nullptr
	zero
	arg	*+1
	oct	524000000030
	arg	*+1
	oct	464000000000
trap_nullptr:
	its	-1,1
trap_cname:aci	"unimplemented_lisp_subr_"

	segdef	purcopy_code
purcopy_code:	" code to do the purcopy function, which is nugatory
	ldaq	ap|-2		just return argument
	eppap	ap|-2
	tra	bp|0

	segdef	star_rset_trap,autoload_trap	" used by transfer vector above

null_argl:	oct	4,0

type_1_subr:			" routine to set up type 1 call entry for system subrs.
	eax7	4,x7		" get room to save lp and bp
	sprilp	ab|-4,x7
	spribp	ab|-2,x7
	epplp	ab|system_lp,*	" get linkage pointer, which all system subrs share.
	tra	0,x6		" return to transfer instruction.

pl1_fixup:			" routine to switch from lisp mode to pl1 mode.
	eax7	6,x7
	spribp	ab|-6,x7
	sprilp	ab|-4,x7
	epplp	0,x6
	sprilp	ab|-2,x7		" save pointer to entry we are calling.
	epplp	ab|system_lp,*	" get system lp.
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code	" now we are in pl1 code conventions.

	push			" make a stack frame.
	eppbp	<lisp_static_vars_>|[unmkd_ptr],*
	epplb	<lisp_subr_tv_>|[..lisp..]
	sprilb	sp|stack_frame.entry_ptr
	eppap	null_argl-*,ic
	short_call bp|-2,*	" call the entry point.
	eppbp	sp|16,*		" pop stack.
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	bp|0		" get old stack ptr.

	eppap	<lisp_static_vars_>|[stack_ptr],*	"go back to lisp conventions.
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	epplp	ab|-4,x7*
	eppbp	ab|-6,x7*
	eax7	-6,x7
	ldaq	ap|-2
	eppap	ap|-2
	tra	bp|0		" return.

pl1_lsubr_fixup:

	eppap	ap|2
	eaq	0,x5		" put x5 on stack.
	qrs	18
	lda	fixnum_type,dl
	staq	ap|-2
	tra	pl1_fixup

""" special internal trap & break routines

autoload_trap:
	epplb	ap|-2,*		pick up argument and take cdr
	ldaq	lb|2
	staq	ap|-2		pass argument's cdr to load function
	tra	load+1-*,ic


err_break:	" x6 -> zero flag,atom_offset
		" flag = -1 if (errprint nil) should be done.
		" atom_offset = offset from lisp_static_vars_$user_intr_array of break tag

	eax7	6,x7		save caller's bp, lp
	sprpbp	ab|-4,x7
	sprplp	ab|-3,x7
	epplp	ab|system_lp,*

star_rset_break:
	" lambda-bind readtable and obarray, and args to argument
	" and + t itself

	eppap	ap|16
	ldaq	<lisp_static_vars_>|[MINUS]
	staq	ap|-14
	ldaq	<lisp_static_vars_>|[MINUS],*		+ hasn't been setq'ed yet
	staq	ap|-16
	staq	<lisp_static_vars_>|[PLUS],*
	ldaq	<lisp_static_vars_>|[args]
	staq	ap|-10
	ldaq	ap|-10,*
	staq	ap|-12
	ldaq	<lisp_static_vars_>|[readtable]
	staq	ap|-6
	ldaq	ap|-6,*
	staq	ap|-8
	ldaq	<lisp_static_vars_>|[obarray]
	staq	ap|-2
	ldaq	ap|-2,*
	staq	ap|-4
	eax0	ap|-16		bot_block
	sxl0	ab|-2,x7
	eax0	ap|0		top_block
	stx0	ab|-2,x7
	lda	<lisp_static_vars_>|[binding_top]+1
	sta	ab|-1,x7
	eax1	ab|-2,x7
	stx1	<lisp_static_vars_>|[binding_top]+1
	ldaq	ap|-18		set args to argument
	staq	ap|-10,*

	" reset readtable, obarray to initial values

	sxl6	ab|-5,x7
	eppap	ap|4
	ldaq	<lisp_static_vars_>|[readtable]
	staq	ap|-4
	ldaq	<lisp_static_vars_>|[array]
	staq	ap|-2
	tspbp	get+1-*,ic
	cmpaq	ab|nil
	tze	2,ic
	staq	ap|-6,*

	ldaq	<lisp_static_vars_>|[obarray]
	eppap	ap|4
	staq	ap|-4
	ldaq	<lisp_static_vars_>|[array]
	staq	ap|-2
	tspbp	get+1-*,ic
	cmpaq	ab|nil
	tze	2,ic
	staq	ap|-2,*

	" if necessary, do (iog vt (errprint nil))

	lxl6	ab|-5,x7
	szn	0,x6
	tpl	err_break_no_errprint-*,ic

	eppap	ap|10		binding + arg
	ldaq	<lisp_static_vars_>|[ctrlW]
	staq	ap|-8
	ldaq	ap|-8,*
	staq	ap|-10
	ldaq	<lisp_static_vars_>|[ctrlR]
	staq	ap|-4
	ldaq	ap|-4,*
	staq	ap|-6
	eax0	ap|-2
	stx0	ab|-2,x7		update top_block
	ldaq	ab|nil
	staq	ap|-2
	staq	ap|-4,*
	staq	ap|-8,*
	tspbp	errprint+1-*,ic
	" unbind ^w and ^r now
	ldaq	ap|-4
	staq	ap|-2,*
	ldaq	ap|-8
	staq	ap|-6,*
	eax0	ap|-8
	stx0	ab|-2,x7		update top_block
	eppap	ap|-8

err_break_no_errprint:
	eppap	ap|4
	ldaq	ab|true		construct arg list for break
	staq	ap|-2
	tspbp	ncons+1-*,ic
	tspbp	ab|xcons_op,*
	lxl6	ab|-5,x7		get back x6
	lxl6	0,x6		get offset into user_intr_array
	ldaq	<lisp_static_vars_>|[user_intr_array],x6	get break tag
	staq	bb|0
	spribb	ap|-2
	tspbp	break+1-*,ic

	" unbind and return

	eppap	ap|2
	staq	ap|-2		save return value
	ldaq	ap|-6
	staq	ap|-4,*
	ldaq	ap|-10
	staq	ap|-8,*
	ldaq	ap|-14
	staq	ap|-12,*
	ldaq	ap|-18
	staq	ap|-16,*
	ldx1	ab|-1,x7
	stx1	<lisp_static_vars_>|[binding_top]+1
	ldaq	ap|-2		return value
	eppap	ap|-20		16 binding + 2 arg + 2 saved result
	lprplp	ab|-3,x7
	lprpbp	ab|-4,x7
	eax7	-6,x7
	tra	bp|0


star_rset_trap:
	eax6	star_rset_trap_control_word-*,ic
	eax7	6,x7
	sprpbp	ab|-4,x7
	sprplp	ab|-3,x7
	epplp	ab|system_lp,*
	ldaq	<lisp_static_vars_>|[star_rset],*
	cmpaq	ab|nil
	tnz	star_rset_break-*,ic
	 " (*rset nil) mode, just return nil
"	ldaq	ab|nil
	eppap	ap|-2
	lprplp	ab|-3,x7
	lprpbp	ab|-4,x7
	eax7	-6,x7
	tra	bp|0

star_rset_trap_control_word:
	zero	0,36

	use	Names
	entry	..lisp..
..lisp..:	drl	0,dl		used to set stack_frame.entry_ptr

	include	stack_header
	include 	stack_frame
	include	lisp_object_types
	include	lisp_stack_seg

	use	tv		hope to get literals in tv section
	join	/text/tv,Names
	end




		    lisp_utils_.alm                 11/05/86  1612.7r w 11/04/86  1039.2      212247



" **************************************************************
" *                                                            *
" * Copyright, (C) Massachusetts Institute of Technology, 1973 *
" *                                                            *
" **************************************************************
" lisp_utils_.alm

" This segment contains the arithmetic functions and
" a few other random functions.

" translated from PL/I to ALM  28 August 1972 by D.A.Moon
" ***** must be bound in with lisp_ and lisp_error_ since
" relies on calling through links without the lp loaded.


	include	lisp_stack_seg
	include	stack_header
	equ	t,true
	include	lisp_object_types
	include	lisp_error_codes
	include	lisp_name_codes

" REGISTER USAGE
"
" ap	marked pdl pointer
" ab	-> lisp stack header
" bp	return addr (type 0 subr)
" bb
" lp,lb,sp,sb     not used
"
" x0	tsx0 register
" x1	-> routine to check arg for arith1, arith2
" x2	temp. used by numval.  badarg is called by tsx2
" x3	-> instr for xec or xed (quasi impure code)
" x4	ap,x4 -> current arg, also x4 is loop counter.
" x5	-2*nargs for lsubrs, not changed.
" x6	while in function xxx, contains function name code fn_xxx.
" x7	unmarked pdl pointer (with ab)

" routine to do eax4 -2   ,   tsx0 numval
" called by tsx0
" used for subrs of one argument so they don't have to
" do the eax4 themselves

numval1:	eax4	-2			and fall into numval

" routine to get the type of a numeric argument
" called by tsx0 with ap,x4 pointing at the argument
" keeps signalling bad_arg_correctable errors until it gets a number
" skip return if fixnum, nonskip return if flonum.
" changes only registers 0,2 -- doesn't touch aq.

numval:	lxl2	ap|0,x4			get type bits without touching aq
	canx2	Fixed,du
	tnz	1,0			fixnum, skip rtn
	canx2	Float,du
	tnz	0,0			flonum, nonskip rtn
	eax2	numval-*,ic		set error return address and fall into badarg

" not a number, signal error
" the function name code is in x6
" the bad arg is at ap|0,x4
" **** KLUDGE: assumes that we are bound in with lisp_error_
"      so that we don't have to do a getlp.
" called by tsx2, returns to 0,2 with replacement value written over bad arg

badarg:	eax7	10,x7			get save area
	sprilp	ab|-10,x7			save lp of caller, so can get system lp.
	staq	ab|-8,x7			save aq (e reg saved by sreg)
	spribp	ab|-6,x7			save bp (return addr)
	eaq	0,x6			get fcn name code
	qrs	18
	lda	bad_arg_correctable,dl
badarg1:
	staq	ab|-2,x7			set error codes for lisp_error_
	eppbp	ap|0,x4			save addr of bad arg
	spribp	ab|-4,x7
	ldaq	bp|0			get bad arg
	eppap	ap|2			put on top of pdl for lisp_error_
	staq	ap|-2
fatal_error:				" overflow_err joins here.
	epplp	ab|system_lp,*		get lp for system modules.
	spriap	<lisp_static_vars_>|[stack_ptr]	save our stack pointers
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	push
	call	<lisp_error_>|[lisp_error_]	""" we rely on this call saving xr's and e reg
	eaa	sp|16,*			then pop this dummy stack frame
	sprisp	sb|stack_header.stack_end_ptr
	eppsp	sb|0,au
	eppap	<lisp_static_vars_>|[stack_ptr],*
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	ldaq	ap|-2			get replacement value
	eppap	ap|-2			..
	staq	ab|-2,x7*			store over bad arg
	ldaq	ab|-6,x7			restore aq at entry
	eppbp	ab|-4,x7*			restore bp at entry
	epplp	ab|-8,x7*			restore to caller's lp.
	eax7	-8,x7			pop temps off pdl
	tra	0,2			return to caller.

	even
	zero	0,nonfixedarg
	oct	0

" routines to return in divers ways

" return the value at the top of the marked pdl (for 1 arg subr)

ret_1:	ldaq	ap|-2

" return value in aq, popping 1 arg off marked pdl

lisp_retn_1: eppap	ap|-2
	tra	bp|0			*** these are type 0 subrs

" return t for 1 arg subr

ret_t:	ldaq	ab|t
	eppap	ap|-2
	tra	bp|0

" return nil for 1 arg subr

ret_nil:	ldaq	ab|nil
	eppap	ap|-2
	tra	bp|0

" return t for lsubr

l_ret_t:	ldaq	ab|t
	eppap	ap|0,x5			pop args off pdl
	tra	bp|0

" return nil for lsubr

l_ret_nil: ldaq	ab|nil
	eppap	ap|0,x5			pop args off pdl
	tra	bp|0
" return a fixnum from an lsubr

retfixnum:lda	fixnum_type,dl			value is in q
	eppap	ap|0,x5
	tra	bp|0

" return a flonum from an lsubr
" value of flonum is in a-q-e

retflonum:fst	ap|1,x5				**** assumes arg 1 was numeric
	ldq	ap|1,x5				this moves flonum to q
	lda	flonum_type,dl
	eppap	ap|0,x5
	tra	bp|0

" fixing & floating routines

" these are all called by tsx0

" routine to float the q, returning result in a-q-e

float_q:	llr	36			fx1_to_fx2
	lrs	36
	lde	=71b25,du			fx2_to_fl2
	fad	=0.0,du			normalize
	tra	0,0

" routine to float the fixnum pointed at by ap,x4 without
" changing the a, q, or e.

float1:	eax7	2,x7			have to save aqe
	dfst	ab|-2,x7
	lda	ap|1,x4			get number to be floated
	lrs	36
	lde	=71b25,du
	fad	=0.0,du
	fst	ap|1,x4			put it back where it came from
	dfld	ab|-2,x7			restore a q e
	eax7	-2,x7
	tra	0,0

" routine to fix the flonum in a-q-e, result is in q
" check for overflow is made

fix_aq:	fad	=0.0,du			normalize and set indicators
	tmi	fix_aq_minus-*,ic
	fcmp	=o110400,du		2**35
	tpl	fix_ovf-*,ic
	ufa	=71b25,du
	tra	0,0

fix_aq_minus:
	fcmg	=o110400,du		2**35
	tpl	fix_ovf-*,ic
	fneg	0			magic ufa only works for +
	ufa	=71b25,du
	negl	0
	tra	0,0

fix_ovf:	eppap	ap|2
	eax7	2,x7
	fst	ab|-2,x7			get flonum format
	ldq	ab|-2,x7
	lda	flonum_type,dl
	staq	ap|-2
	lda	overflow_err,dl
	eaq	0,x6
	qrs	18
	staq	ab|-2,x7
	tra	fatal_error-*,ic		never returns from lisp_error_
 
" routines for fixnum - only or flonum - only incrementing / decrementing.
" x3 -> xed pair to do the work
"	for arith2 is xec inst, which can be xed if pair needed.
" x1 -> fixval or floval routine
" x6 =  function name code.

" these 2 support routines are called by tsx0 to get a
" floating number or a fixed number.

	tra	retflonum			flo exit
floval:	lxl2	ap|0,x4			get type bits
	canx2	Float,du
	tnz	0,0			flonum -- win.
	tsx2	badarg-*,ic		not flonum, cause error
	tra	floval-*,ic

	tra	retfixnum			fix exit
fixval:	lxl2	ap|0,x4			check type bits
	canx2	Fixed,du
	tnz	0,0			fixnum -- win.
	tsx2	badarg-*,ic		not fixnum -- error.
	tra	fixval-*,ic

" routine to do one - operand arithmetic using
" x3, x1 as described above.  Entered with x6 also set up.

	odd
arith1:	eax4	-2			one arg.
	tsx0	0,1			check type of arg
	xed	0,x3			perform operation.
	tra	ret_1-*,ic		and return the value at top of stack.



" using x3, x1 as described above. Entered
" with x5, x6 set up.
" and initial value in q (fix) or aqe (float).

	odd				" must make the xec in odd word to allow xed.
prearith2: cmpx5	-2,du			" check for one arg case of -, -$, //, //$
	tnz	arith2
	tsx0	0,1
	xec	3,x3			" do the operation.
	tra	-1,x1			" and return the result.
arith2:	eax4	0,x5			-> first arg
	tze	-1,1			if no args return value in q register.
	tsx0	0,1			check type of arg
	xec	0,x3			perform operation
	eax4	2,x4			next arg.
	tmi	-3,ic			and loop.
	tra	-1,1			go to appropriate exit routine.

" non - mixed mode increment / decrement routines. (Using subroutines
" on the preceding page.)

" increment fixnum.

	segdef	add1_fix			subr (1 0 0)

add1_fix:	eax6	fn_add1_fix
	eax1	fixval-*,ic
	eax3	add1_fix_op-*,ic
	tra	arith1-*,ic

	even
add1_fix_op:
	aos	ap|-1
	nop	0,du


" increment flonum

	segdef	add1_flo			subr (1 0 0)

add1_flo:	eax6	fn_add1_flo
	eax1	floval-*,ic
	eax3	add1_flo_op-*,ic
	tra	arith1-*,ic

	even
add1_flo_op:
	fld	ap|-1
	xed	*+1
	fad	=1.0,du
	fst	ap|-1


" decrement fixnum

	segdef	sub1_fix			subr (1 0 0)

sub1_fix:	eax6	fn_sub1_fix
	eax1	fixval-*,ic
	eax3	sub1_fix_op-*,ic
	tra	arith1-*,ic

	even
sub1_fix_op:
	lca	1,dl
	asa	ap|-1


" decrement flonum

	segdef	sub1_flo			subr (1 0 0)

sub1_flo:	eax6	fn_sub1_flo
	eax1	floval-*,ic
	eax3	sub1_flo_op-*,ic
	tra	arith1-*,ic

	even
sub1_flo_op:
	fld	ap|-1
	xed	*+1
	fsb	=1.0,du
	fst	ap|-1

" plus function for fixnums only.

	segdef	plus_fix		lsubr (777000 0 0)

plus_fix:	eax6	fn_plus_fix
	eax1	fixval-*,ic
	ldq	0,dl
	tsx3	arith2-*,ic
	adq	ap|1,x4


" plus function for flonum's only.

	segdef	plus_flo			lsubr (777000 0 0)

plus_flo:	eax6	fn_plus_flo
	eax1	floval-*,ic
	fld	=0.0,du
	tsx3	arith2-*,ic
	fad	ap|1,x4

" exponentiation function for fixnum to fixnum power

	segdef	expt_fix

expt_fix:	eax6	fn_expt_fix
	eax4	-4			get first arg
	tsx0	fixval-*,ic
	eax4	-2			get second arg
	tsx0	fixval-*,ic
" OK, got args.  Set up for successive squaring hackery

	eax7	2,x7
	ldq	ap|-3			base in q
	lda	ap|-1			exponent in a
	tmi	ret_fix_0-*,ic
	staq	ab|-2,x7
	ldq	1,dl
	stq	ap|-3			init result
expt_fix0:ldaq	ab|-2,x7
	cana	1,dl
	tze	expt_fix1-*,ic
	mpy	ap|-3			multiply into result
	stq	ap|-3
	ldaq	ab|-2,x7
expt_fix1:arl	1
	tze	ret_fix_result-*,ic
	sta	ab|-2,x7
	mpy	ab|-1,x7			square it
	stq	ab|-1,x7
	tra	expt_fix0-*,ic

ret_fix_0:stz	ap|-3			neg exponent - zero result
ret_fix_result:
	ldaq	ap|-4			pick up result & type
	eax7	-2,x7			flush temporaries
	eppap	ap|-4			..
	tra	bp|0			and return

" flonum to a fixnum power

	segdef	expt_flo

expt_flo:	eax6	fn_expt_flo
	eax4	-4			get first arg
	tsx0	floval-*,ic
	eax4	-2			get second arg
	tsx0	fixval-*,ic
	eax7	2,x7			get temporaries
	fld	=1.0,du			init result
	dfst	ab|-2,x7
	lda	ap|-1			check sign of exponent
	tpl	expt_fl0-*,ic
	fld	=1.0,du			minus - invert base
	fdv	ap|-3
	fst	ap|-3
	lca	ap|-1			change sign of exponent
expt_fl0:	tze	return_flo_result-*,ic	all done
	cana	1,dl			see if should mpy
	tze	expt_fl1-*,ic		no.
	sta	ap|-1			yes - store a first
	fld	ap|-3			get current square
	dfmp	ab|-2,x7			mpy into result
	dfst	ab|-2,x7
	tra	2,ic
expt_fl1:	sta	ap|-1			save exponent
	fld	ap|-3			compute next square
	fmp	ap|-3
	fst	ap|-3
	lda	ap|-1
	arl	1
	tra	expt_fl0-*,ic

return_flo_result:
	dfld	ab|-2,x7			round off result
	fstr	ap|-3
	tra	ret_fix_result-*,ic		and return it, popping, etc.

" times function for fixnum's only

	segdef	times_fix			lsubr (777000 0 0)

times_fix: eax6	fn_times_fix
	eax1	fixval-*,ic
	ldq	1,dl
	tsx3	arith2-*,ic
	mpy	ap|1,x4


" times function for flonum's only

	segdef	times_flo			lsubr (777000 0 0)

times_flo: eax6	fn_times_flo
	eax1	floval-*,ic
	fld	=1.0,du
	tsx3	arith2-*,ic
	fmp	ap|1,x4

" difference of fixnum's only

	segdef	diff_fix			lsubr (777000 0 0)

diff_fix:	eax6	fn_diff_fix
	eax1	fixval-*,ic
	ldq	0,dl			make sure there is a result if no args supplied.
	eax3	diff_fix_op_1-*,ic		initial op just loads num
	tra	prearith2-*,ic

	odd
diff_fix_op_1:
	xed	*+1
	ldq	ap|1,x4			load first arg
	eax3	*+1			and switch to the following,
	sbq	ap|1,x4			which subtracts the remaining args

" difference of flonum's only.

	segdef	diff_flo			lsubr (777000 0 0)

diff_flo:	eax6	fn_diff_flo
	eax1	floval-*,ic
	fld	=0.0,du			initial result.
	eax3	diff_flo_op_1-*,ic
	tra	prearith2-*,ic

	odd
diff_flo_op_1:
	xed	*+1
	fld	ap|1,x4			load first arg,
	eax3	*+1			and set up subtract remaining args
	fsb	ap|1,x4

" quotient of fixnum's only

	segdef	quot_fix			lsubr (777000 0 0)

quot_fix:	eax6	fn_quot_fix
	eax1	fixval-*,ic
	ldq	1,dl			initialize zero arg case.
	eax3	quot_fix_op_1-*,ic		initial operator
	tra	prearith2-*,ic

	odd
quot_fix_op_1:
	xed	*+1
	ldq	ap|1,x4			this opr loads first arg,
	eax3	*+1			and sets up to divide by rest of args
	div	ap|1,x4

" quotient of flonum's only

	segdef	quot_flo			lsubr (777000 0 0)

quot_flo:	eax6	fn_quot_flo
	eax1	floval-*,ic
	fld	=1.0,du			initialize zero arg case.
	eax3	quot_flo_op_1-*,ic
	tra	prearith2-*,ic

	odd
quot_flo_op_1:
	xed	*+1
	fld	ap|1,x4			load first arg
	eax3	*+1
	fdv	ap|1,x4			divide by remaining ones.

" lsh function shifts a fixnum left or right a 
" specified number of binary places.

	segdef	lsh			subr (2 0 0)

lsh:	eax6	fn_lsh
	eax4	-4			arg1 must be fixnum
	tsx0	numval-*,ic 		or flonum (treated as fixnum)
	eax4	-2			arg2 must be fixnum
	tsx0	fixval-*,ic
	ldq	ap|-3			get number to be shifted
	lda	ap|-1			get shift count
	tmi	lshneg-*,ic		neg = shift right
	tze	lshret1-*,ic		zero = don't shift
	cmpa	36,dl			shift right out of register?
	tpl	lshret0-*,ic		yes, result is zero
	qls	0,al			no, shift.
	tra	lshret1-*,ic

lshneg:	neg	0			get count of right shifts
	cmpa	36,dl			shift right out of reg?
	tpl	lshret0-*,ic		yes, result is zero
	qrl	0,al			no, do the shift
	tra	lshret1-*,ic

lshret0:	ldq	0,dl
lshret1:	lda	fixnum_type,dl
	eppap	ap|-4
	tra	bp|0

" fsc function, takes a flonum and scales it. (ade instruction).

	segdef	fsc
fsc:	eax6	fn_fsc
	eax4	-4		" first arg must be a fixnum or flonum
	tsx0	numval
	eax4	-2
	tsx0	fixval

	lda	ap|-1		" get scale factor.
	als	36-8		" shift to exponent position.
	sta	ap|-1
	fld	ap|-3		" load up the floating point number.
	fad	=0.0,du		" normalize
	ade	ap|-1		" scale.
	fst	ap|-3
	ldq	ap|-3
	lda	flonum_type,dl

	eppap	ap|-4
	tra	bp|0

" rot function rotates a fixnum left or right a
" specified number of binary places

	segdef	rot			subr (2 0 0)

rot:	eax6	fn_rot
	eax4	-4			arg1 must be fixnum
	tsx0	fixval-*,ic
	eax4	-2			arg2 must be fixnum
	tsx0	fixval-*,ic
	ldq	ap|-1			get shift count
	div	36,dl			modulo word length
	ada	0,dl			set indicators from a (remainder)
	tpl	2,ic
	ada	36,dl			if right rot is indicated, use
					"the equivalent left rot.
	tze	rot0-*,ic			if shift count is zero
	ldq	ap|-3			get number to be rotated
	qlr	0,al			do it
	tra	lshret1-*,ic		and return it.

rot0:	ldq	ap|-3			(rot num 0)
	tra	lshret1-*,ic		just returns argument 1.

" ifix function -- fixes a floating argument, into a fixnum.
" if arg is too large, is an error.

	segdef	ifix
ifix:	eax6	fn_ifix
	eax4	-2
	tsx0	floval
	fld	ap|-1
	fcmg	maxfix
	tmi	3,ic
	tsx2	badarg
	tra	ifix
	ufa	=71b25,du
	lda	fixnum_type,dl
	eppap	ap|-2
	tra	bp|0
maxfix:	vfd	8/36,1/0,1/1	" maximum fixnum in flonum form.

" boole function
" uses first arg to determine operation to be performed on remaining args

	segdef	boole			lsubr (777003 0 0)

boole:	eax6	fn_boole
	eax4	0,x5
	tsx0	fixval-*,ic		get first arg which must be fixnum
	lda	ap|1,x4			get first arg
	ana	=o17,dl			low 4 bits only
	als	1			times 2
	eax3	0,al			put into x3
	eax4	2,x4			get 2nd arg
	tsx0	fixval-*,ic
	lda	ap|1,x4			put second arg in result accumulator
boole_loop:
	eax4	2,x4			get next arg
	tpl	boole_fin-*,ic		done -- leave.
	tsx0	fixval-*,ic

	xed	boole_op,x3		do operation
	tra	boole_loop-*,ic		and get next arg

boole_fin: lrl	36			make fixnum to return
	lda	fixnum_type,dl
	eppap	ap|0,x5
	tra	bp|0

" table of operations for boole
" the first operand is in the a
" the second operand is in ap|1,x4
" the result goes in the a
" these operations are called by xed.

	even
boole_op:
	lda	0,dl			(0) SETZ
	tra	boole_loop

	ana	ap|1,x4			(1) AND
	tra	boole_loop

	era	ones			(2) ANDCA
	ana	ap|1,x4

	lda	ap|1,x4			(3) SETM
	tra	boole_loop

	era	ones			(4) ANDCM
	xed	andcb

	tra	boole_loop		(5) SETA
	nop	0,du

	era	ap|1,x4			(6) XOR
	tra	boole_loop

	ora	ap|1,x4			(7) IOR
	tra	boole_loop

andcb:	ora	ap|1,x4			(10) ANDCB
	era	ones

	era	ap|1,x4			(11) EQV
	era	ones

	era	ones			(12) SETCA
	tra	boole_loop

	era	ones			(13) ORCA
	ora	ap|1,x4

	lda	ap|1,x4			(14) SETCM
	era	ones

	era	ones			(15) ORCM
	xed	orcb

orcb:	ana	ap|1,x4			(16) ORCB
	era	ones

	lda	ones			(17) SETO
	tra	boole_loop

" constant for complementing - all ones

ones:	oct	777777777777

" the single-word comparison operators, <, > and =, must check for error
" cases in the interpreter, so they are not identical to greaterp, lessp and eq.

	segdef	ls_
ls_:	eax6	fn_ls
	tsx3	compare_words_with_type
	tmi	ret_t_2
	tra	ret_nil_2

	segdef	gt_
gt_:	eax6	fn_gt
	tsx3	compare_words_with_type
	tze	ret_nil_2
	tpl	ret_t_2
	tra	ret_nil_2

	segdef	eql_
eql_:	eax6	fn_eql
	tsx3	compare_words_with_type
	tze	ret_t_2
	tra	ret_nil_2


compare_words_with_type:
	eax4	-4		get first argument.
	tsx0	numval		evaluate number...make sure it is one word fix or float
	tra	cmp_flt		if float, numval does not skip.
	eax4	-2
	tsx0	fixval		verify that val is fixed.
	ldq	ap|-3
	cmpq	ap|-1
	tra	0,x3		x3 must have been preserved.

cmp_flt:	eax4	-2
	tsx0	floval		verfy second arg is also float.
	fld	ap|-3
	fcmp	ap|-1
	tra	0,x3		return

ret_t_2:	ldaq	ab|true		return t.
	eppap	ap|-4
	tra	bp|0		and go to caller.

ret_nil_2:
	ldaq	ab|nil		load up nil.
	eppap	ap|-4
	tra	bp|0		return to caller.

" the typep function returns an atomic symbol
" whose name designates the type of object given it as argument.
" This is a type 1 subr since the return values are constants
" in lisp_static_vars_ (We need our lp)

	segdef	typep			subr (1 1 0)

" define constants in lisp_static_vars_

	link	pname,<lisp_static_vars_>|[pname_atom]
	link	string,<lisp_static_vars_>|[string_atom]
	link	fixnum,<lisp_static_vars_>|[fixnum_atom]
	link	flonum,<lisp_static_vars_>|[flonum_atom]
	link	random,<lisp_static_vars_>|[random_atom]
	link	bignum,<lisp_static_vars_>|[bignum_atom]
	link	list,<lisp_static_vars_>|[list_atom]
	link	array,<lisp_static_vars_>|[array_atom]

typep:	lda	ap|-2			get argument
	eppap	ap|-2			pop pdl
	tze	typep_4-*,ic		Undefined = random
	cana	Atsym,dl
	tnz	typep_1-*,ic
	cana	Big_fixed,dl
	tnz	typep_big-*,ic
	cana	Fixed,dl
	tnz	typep_2-*,ic
	cana	Float,dl
	tnz	typep_3-*,ic
	cana	String,dl
	tnz	typep_str-*,ic
	cana	Array,dl
	tnz	typep_array-*,ic
	cana	lisp_ptr.type,dl
	tnz	typep_4-*,ic
	ldaq	lp|list,*
typep_xx:
retrn_type_1:
	epplp	ab|-4,x7*			return from type 1 subr
	eppbp	ab|-2,x7*
	eax7	-4,x7
	tra	bp|0

typep_1:	ldaq	lp|pname,*
	tra	typep_xx-*,ic

typep_array:
	ldaq	lp|array,*
	tra	typep_xx-*,ic

typep_str:ldaq	lp|string,*
	tra	typep_xx-*,ic

typep_big:ldaq	lp|bignum,*
	tra	typep_xx-*,ic

typep_2:	ldaq	lp|fixnum,*
	tra	typep_xx-*,ic

typep_3:	ldaq	lp|flonum,*
	tra	typep_xx-*,ic

typep_4:	ldaq	lp|random,*
	tra	typep_xx-*,ic

	entry	pl1_sxhash
pl1_sxhash:
	epbpab	<lisp_static_vars_>|[unmkd_ptr],*
	eppap	<lisp_static_vars_>|[stack_ptr],*
	ldx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stz	ab|in_pl1_code
	eax7	4,x7
	sprilp	ab|-4,x7		" save lp and return address.
	stcd	ab|-2,x7
	tra	sxhash		" and call the lisp routine.
	eppap	ap|2		" now put result back on stack.
	staq	ap|-2
	spriap	<lisp_static_vars_>|[stack_ptr]
	stx7	<lisp_static_vars_>|[unmkd_ptr]+1
	stc1	ab|in_pl1_code
	short_return

	segdef	sxhash		" s-expression hash routine.
sxhash:	eax5	0,x7		" x5 points to two numeric temps.
	eax7	2,x7		" x7 keeps top of stack, as usual.
	stz	ab|0,x5		" make sure result starts at zero.
	ldaq	ap|-2		" load argument.
	tsx6	hash_fcn	" call hasher.
	ldq	ab|0,x5		" load result
	eax7	-2,x7
	eppap	ap|-2		" pop arg off stack
	lda	fixnum_type,dl	" make it a fixnum to return
	tra	retrn_type_1	" and return.

hash_fcn:	cmpa	fixnum_type,dl	" check type and go to appropriate routine
	tze	hash_fix
	cmpa	flonum_type,dl
	tze	hash_float
	cana	Atsym,dl
	tnz	hash_sym
	cana	Big_fixed,dl
	tnz	hash_big
	cana	String,dl
	tnz	hash_str
	cana	Atomic,dl
	tnz	0,x6		" return if unknown type.

	eppbp	ap|-2,*
	eppap	ap|2		" must get car and cdr of list.
	ldaq	bp|2
	staq	ap|-4		" store cdr for later use
	ldaq	bp|0
	staq	ap|-2		" and make car the arg.
	eax7	2,x7		" get room to save return address
	stx6	ab|-2,x7		" store return address.
	tsx6	hash_fcn
	ldq	ab|0,x5		" now rotate hash result right.
	qlr	35		" rotate right 1
	stq	ab|0,x5
	ldx6	ab|-2,x7		" get back return address.
	eax7	-2,x7
	eppap	ap|-2		" pop off stacks
	ldaq	ap|-2		" get cdr of list
	tra	hash_fcn	" and go back and try again.

hash_fix:	adlq	ab|0,x5
	stq	ab|0,x5		" store new hash result.
	tra	0,x6

hash_float:
	fld	ap|-1		" fix up float number for compatibility with PDP10
	tpl	3,ic
	fneg	0,dl
	fst	ap|-1		" store abs val back
	ldq	ap|-1		" now get word of float number
	lls	9
	ana	=o777,dl
	ars	1
	lrl	9		" move back to q
	tra	hash_fix

hash_sym:	eppbp	ap|-2,*		" get pointer to atsym
	eppbp	bp|4		" make pointer point to string.
hash_chrs:
	ldq	bp|0		" load length
	tze	0,x6		" if zero, don't bother with rest
	adq	3,dl
	qrs	2		" divide by 4
hash_com:	eax4	0,ql		" and move length to x4
	stz	ab|1,x5		" zero temporary.
	ldq	bp|0,x4		" load the last word so far of the string
	ersq	ab|1,x5		" and xor into result
	eax4	-1,x4		" move back
	tnz	-3,ic		" and loop
	ldq	ab|1,x5		" load up the hash result
	tra	hash_fix		" and put it into result

hash_str:	eppbp	ap|-2,*
	tra	hash_chrs

hash_big:	eppbp	ap|-2,*		" get pointer to bignum
	ldq	bp|0		" get number of words
	anq	-1,dl		" and mask word length out
	tra	hash_com

" the signp function, which tests whether the sign
" of the second argument (evaluated) matches the sign of the
" designation in the first argument (unevaluated), which can
" be l,le,e,n,ge,g,a
" this is a type 1 subr since it needs to call eval.

	segdef	signp			fsubr (0 1 0)

signp:	eppap	ap|2			room for temp
	eax2	2
	eppbp	ap|-4,*2			bp = cdr of arg list
	eppbp	bp|0,*
	ldaq	bp|0			get cadr of arg list, = 2nd arg
	staq	ap|-2			save for evaluation
	ldaq	ap|-4,*			get car of arg list
	staq	ap|-4			save it.
	eax7	4,x7			call eval to do 2nd arg
	sprilp	ab|-4,x7
	eax5	-2
	stcd	ab|-2,x7			**** Must be bound in with lisp_
	tra	<lisp_>|[eval_]
	eppap	ap|2			put result back in pdl
	staq	ap|-2
	cmpa	flonum_type,dl
	tze	signp_flt-*,ic
	cana	Big_fixed,dl
	tnz	signp_big-*,ic
	cmpa	fixnum_type,dl
	tnz	signp_nil-*,ic		not a number, just return nil.
	szn	ap|-1
	tmi	signp_neg-*,ic
	tze	signp_zero-*,ic
	tpl	signp_plus-*,ic

signp_big:szn	ap|-2,*		points at first word of bignum, upper bit = sign.
	tmi	signp_neg-*,ic
	tra	signp_plus-*,ic	can't be zero if a bignum.
signp_flt:fszn	ap|-1
	tmi	signp_neg-*,ic
	tze	signp_zero-*,ic
	tpl	signp_plus-*,ic


signp_neg:eax5	-1
	tra	signp_com-*,ic

signp_zero:
	eax5	0
	tra	signp_com-*,ic

signp_plus:
	eax5	+1
	"tra	signp_com-*,ic

signp_com:
	" decode first argument

	lda	ap|-4			must be atomic symbol
	cana	Atsym,dl
	tze	bad_signp-*,ic
	eppbp	ap|-4,*			-> atomic symbol
	lda	bp|4			get pnamel
	cmpa	1,dl
	tnz	signp_2-*,ic
					" must be l,g,a,e,n
	lda	bp|5			get the 1 char pname
	cmpa	=o154000,du		l ?
	tnz	xx01-*,ic
	  cmpx5	 -1,du			yes, neg?
	  tze	 signp_t-*,ic		yes, return t.
	  tra	 signp_nil-*,ic		no, return nil
xx01:	cmpa	=o147000,du		g ?
	tnz	xx02-*,ic
	 cmpx5	 +1,du			yes, pos?
	 tze	 signp_t-*,ic		yes, return t.
	 tra	 signp_nil-*,ic		no, return nil.
xx02:	cmpa	=o141000,du		a ?
	tze	signp_t-*,ic		yes, always t.
	cmpa	=o145000,du		e ?
	tnz	xx03-*,ic
	 cmpx5	 0,du			yes, zero?
	 tze	 signp_t-*,ic		yes, return t.
	 tra	 signp_nil-*,ic		no, return nil.
xx03:	cmpa	=o156000,du		n ?
	tnz	bad_signp-*,ic		no, illegal.
	 cmpx5	 0,du			yes, nonzero?
	 tnz	 signp_t-*,ic		yes, return t.
	 tra	 signp_nil-*,ic		no, return nil.

" signp with 1st arg of length 2. Must be le or ge

signp_2:	cmpa	2,dl			really length 2?
	tnz	bad_signp-*,ic		no, error.
	lda	bp|5			yes, get the pname
	cmpa	=o147145,du		ge ?
	tnz	xx04-*,ic
	 cmpx5	 0,du			yes, pos or 0?
	 tpl	 signp_t-*,ic		yes, return t.
	 tra	 signp_nil-*,ic		no, return nil.
xx04:	cmpa	=o154145,du		le ?
	tnz	bad_signp-*,ic		no, error.
	 cmpx5	 1,du			is it neg or zero?
	 tnz	 signp_t-*,ic		yes, return t.
	 tra	 signp_nil-*,ic		no, return nil.

" routines to return t or nil for signp

signp_t:	ldaq	ab|t
	tra	2,ic

signp_nil:ldaq	ab|nil
subr_1_2_exit:
	eppap	ap|-4
	tra	typep_xx-*,ic		exit from type 1 subr

" come here when first arg to signp is bad.

bad_signp:eax4	-4
	eax6	fn_signp
	eax2	signp_com-*,ic
	tra	badarg-*,ic		returns to signp_com

	segdef	fixgcd	" lisp \\ subr.
fixgcd:	eax6	fn_gcd
	eax4	-4
	tsx0	fixval
	eax4	-2
	tsx0	fixval
	lda	ap|-3	" load first arg
	tpnz	pos1st
	tze	lshret0
	neg	0
	sta	ap|-3
pos1st:	lda	ap|-1
	tpnz	pos2nd
	tze	lshret0
	neg	0
	sta	ap|-1
pos2nd:	cmpa	ap|-3
	tmi	noexch
	ldq	ap|-3
	stq	ap|-1
	sta	ap|-3
noexch:	ldq	ap|-3
	div	ap|-1
	cmpa	0,dl
	tze	retgcd
	ldq	ap|-1
	sta	ap|-1
	tra	-5,ic
retgcd:	ldaq	ap|-2
	eppap	ap|-4
	tra	bp|0

	end


*/
                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull
and Bull HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for 
managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by Bull HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved

*/
