.asciz "$Header: qfuncl.c,v 1.10 84/02/29 16:44:30 sklower Exp $"

/*					-[Mon Mar 21 17:04:58 1983 by jkf]-
 * 	qfuncl.c				$Locker:  $
 * lisp to C interface
 *
 * (c) copyright 1982, Regents of the University of California
 */

/* 
 * This is written in assembler but must be passed through the C preprocessor
 * before being assembled.
 */

#include "ltypes.h"
#include "config.h"

/* important offsets within data types for atoms */
#define Atomfnbnd 8

/*  for arrays */
#define Arrayaccfun 0

#ifdef PROF
	.set	indx,0
#define Profile \
	movab	prbuf+indx,r0 \
	.set 	indx,indx+4 \
	jsb 	mcount
#define Profile2 \
	movl   r0,r5 \
	Profile	\
	movl   r5,r0 
#else
#define Profile
#define Profile2
#endif

#ifdef PORTABLE
#define NIL	_nilatom
#define NP	_np
#define LBOT	_lbot
#else
#define NIL	0
#define NP	r6
#define LBOT	r7
#endif


/*   transfer  table linkage routine  */

	.globl	_qlinker
_qlinker:
	.word 	0xfc0			# save all possible registers
	Profile
	tstl	_exception	        # any pending exceptions
	jeql	noexc
	tstl	_sigintcnt		# is it because of SIGINT
	jeql	noexc			# if not, just leave
	pushl	$2			# else push SIGINT
	calls	$1,_sigcall
noexc:
	movl	16(fp),r0		# get return pc
	addl2	-4(r0),r0		# get pointer to table
	movl	4(r0),r1		# get atom pointer
retry:					# come here after undef func error
	movl	Atomfnbnd(r1),r2	# get function binding
	jleq	nonex			# if none, leave
	tstl	_stattab+2*4		# see if linking possible (Strans)
	jeql	nolink			# no, it isn't
	ashl	$-9,r2,r3		# check type of function
	cmpb	$/**/BCD,_typetable+1[r3]	
	jeql	linkin			# bcd, link it in!
	cmpb	$/**/ARRAY,_typetable+1[r3] # how about array?
	jeql	doarray			# yep


nolink:
	pushl	r1			# non, bcd, call interpreter
	calls	$1,_Ifuncal
	ret

/*
 * handle arrays by pushing the array descriptor on the table and checking
 * for a bcd array handler
 */
doarray:
	ashl	$-9,Arrayaccfun(r2),r3	# get access function addr shifted
	cmpb	$/**/BCD,_typetable+1[r3]	# bcd??
	jneq	nolink			# no, let funcal handle it
#ifdef PORTABLE
	movl	NP,r4
	movl	r2,(r4)+		# store array header on stack
	movl	r4,NP
#else
	movl	r2,(r6)+		# store array header on stack
#endif
	movl	*(r2),r2		# get in func addr
	jmp	2(r2)			# jump in beyond calls header
	
	
linkin:	
	ashl	$-9,4(r2),r3		# check type of function discipline
	cmpb	$0,_typetable+1[r3]	# is it string?
	jeql	nolink			# yes, it is a c call, so dont link in
	movl	(r2),r2			# get function addr
	movl	r2,(r0)			# put fcn addr in table
	jmp	2(r2)			# enter fcn after mask

nonex:	pushl	r0			# preserve table address
	pushl	r1			# non existant fcn
	calls	$1,_Undeff		# call processor
	movl	r0,r1			# back in r1
	movl	(sp)+,r0		# restore table address
	jbr	retry			# for the retry.


	.globl	__erthrow		# errmessage for uncaught throws
__erthrow: 
	.asciz	"Uncaught throw from compiled code"

	.globl _tynames
_tynames:
	.long	NIL				# nothing here
	.long	_lispsys+20*4			# str_name
	.long	_lispsys+21*4			# atom_name
	.long	_lispsys+19*4			# int_name
	.long	_lispsys+23*4			# dtpr_name
	.long	_lispsys+22*4			# doub_name
	.long	_lispsys+58*4			# funct_name
	.long	_lispsys+103*4			# port_name
	.long	_lispsys+47*4			# array_name
	.long	NIL				# nothing here
	.long	_lispsys+50*4			# sdot_name
	.long	_lispsys+53*4			# val_nam
	.long	NIL				# hunk2_nam
	.long	NIL				# hunk4_nam
	.long	NIL				# hunk8_nam
	.long	NIL				# hunk16_nam
	.long	NIL				# hunk32_nam
	.long	NIL				# hunk64_nam
	.long	NIL				# hunk128_nam
	.long	_lispsys+124*4			# vector_nam
	.long	_lispsys+125*4			# vectori_nam

/*	Quickly allocate small fixnums  */

	.globl	_qnewint
_qnewint:
	Profile
	cmpl	r5,$1024
	jgeq	alloc
	cmpl	r5,$-1024
	jlss	alloc
	moval	_Fixzero[r5],r0
	rsb
alloc:
	movl	_int_str,r0			# move next cell addr to r0
	jlss	callnewi			# if no space, allocate
	incl	*_lispsys+24*4			# inc count of ints
	movl	(r0),_int_str			# advance free list
	movl	r5,(r0)				# put baby to bed.
	rsb
callnewi:
	pushl	r5
	calls	$0,_newint
	movl	(sp)+,(r0)
	rsb


/*  _qoneplus adds one to the boxed fixnum in r0
 * and returns a boxed fixnum.
 */

	.globl	_qoneplus
_qoneplus:
	Profile2
	addl3	(r0),$1,r5
#ifdef PORTABLE
	movl	r6,NP
	movl	r6,LBOT
#endif
	jmp	_qnewint

/* _qoneminus  subtracts one from the boxes fixnum in r0 and returns a
 * boxed fixnum
 */
	.globl	_qoneminus
_qoneminus:
	Profile2
	subl3	$1,(r0),r5
#ifdef PORTABLE
	movl	r6,NP
	movl	r6,LBOT
#endif
	jmp	_qnewint

/*
 *	_qnewdoub quick allocation of a initialized double (float) cell.
 *	This entry point is required by the compiler for symmetry reasons.
 *	Passed to _qnewdoub in r4,r5 is a double precision floating point
 *	number.  This routine allocates a new cell, initializes it with
 *	the given value and then returns the cell.
 */

	.globl	_qnewdoub
_qnewdoub:
	Profile
	movl	_doub_str,r0			# move next cell addr to r0
	jlss	callnewd			# if no space, allocate
	incl	*_lispsys+30*4			# inc count of doubs
	movl	(r0),_doub_str			# advance free list
	movq	r4,(r0)				# put baby to bed.
	rsb

callnewd:
	movq	r4,-(sp)			# stack initial value
	calls	$0,_newdoub
	movq	(sp)+,(r0)			# restore initial value
	rsb

	.globl	_qcons

/*
 * quick cons call, the car and cdr are stacked on the namestack
 * and this function is jsb'ed to.
 */

_qcons:
	Profile
	movl	_dtpr_str,r0			# move next cell addr to r0
	jlss	getnew				# if ran out of space jump
	incl	*_lispsys+28*4			# inc count of dtprs
	movl	(r0),_dtpr_str			# advance free list
storit:
	movl	-(r6),(r0)			# store in cdr
	movl	-(r6),4(r0)			# store in car
	rsb

getnew:
#ifdef PORTABLE
	movl	r6,NP
	movab	-8(r6),LBOT
#endif
	calls	$0,_newdot			# must gc to get one
	jbr	storit				# now initialize it.

/*
 * Fast equivalent of newdot, entered by jsb
 */

	.globl	_qnewdot
_qnewdot:
	Profile
	movl	_dtpr_str,r0			# mov next cell addr t0 r0
	jlss	mustallo			# if ran out of space
	incl	*_lispsys+28*4			# inc count of dtprs
	movl	(r0),_dtpr_str			# advance free list
	clrq	(r0)
	rsb
mustallo:
	calls	$0,_newdot
	rsb

/*  prunel  - return a list of dtpr cells to the free list
 * this is called by the pruneb after it has discarded the top bignum 
 * the dtpr cells are linked through their cars not their cdrs.
 * this returns with an rsb
 *
 * method of operation: the dtpr list we get is linked by car's so we
 * go through the list and link it by cdr's, then have the last dtpr
 * point to the free list and then make the free list begin at the
 * first dtpr.
 */
qprunel:
	movl	r0,r2				# remember first dtpr location
rep:	decl	*_lispsys+28*4			# decrement used dtpr count
	movl	4(r0),r1			# put link value into r1
	jeql	endoflist			# if nil, then end of list
	movl	r1,(r0)				# repl cdr w/ save val as car
	movl	r1,r0				# advance to next dtpr
	jbr	rep				# and loop around
endoflist:
	movl	_dtpr_str,(r0)			# make last 1 pnt to free list
	movl	r2,_dtpr_str			# & free list begin at 1st 1
	rsb

/*
 * qpruneb - called by the arithmetic routines to free an sdot and the dtprs
 * which hang on it.
 * called by
 *	pushl	sdotaddr
 *	jsb	_qpruneb
 */
	.globl	_qpruneb
_qpruneb:
	Profile
	movl	4(sp),r0				# get address
	decl	*_lispsys+48*4		# decr count of used sdots
	movl	_sdot_str,(r0)		# have new sdot point to free list
	movl	r0,_sdot_str		# start free list at new sdot
	movl	4(r0),r0		# get address of first dtpr
	jneq	qprunel			# if exists, prune it
	rsb				# else return.


/*
 * _qprunei 	 
 *	called by the arithmetic routines to free a fixnum cell
 * calling sequence
 *	pushl	fixnumaddr
 *	jsb	_qprunei
 */

	.globl	_qprunei
_qprunei:
	Profile
	movl	4(sp),r0		# get address of fixnum
	cmpl	r0,$_Lastfix		# is it a small fixnum
	jleq	skipit			# if so, leave
	decl	*_lispsys+24*4		# decr count of used ints
	movl	_int_str,(r0)		# link the fixnum into the free list
	movl	r0,_int_str
skipit:
	rsb


	.globl	_qpopnames
_qpopnames:			# equivalent of C-code popnames, entered by jsb.
	movl	(sp)+,r0	# return address
	movl	(sp)+,r1	# Lower limit
	movl	_bnp,r2		# pointer to bind stack entry
qploop:
	subl2	$8,r2		# for(; (--r2) > r1;) {
	cmpl	r2,r1		# test for done
	jlss	qpdone		
	movl	(r2),*4(r2)	# r2->atm->a.clb = r2 -> val;
	brb	qploop		# }
qpdone:
	movl	r1,_bnp		# restore bnp
	jmp	(r0)		# return

/*
 * _qget : fast get subroutine
 *  (get 'atom 'ind)
 * called with -8(r6) equal to the atom
 *	      -4(r6) equal to the indicator
 * no assumption is made about LBOT
 * unfortunately, the atom may not in fact be an atom, it may
 * be a list or nil, which are special cases.
 * For nil, we grab the nil property list (stored in a special place)
 * and for lists we punt and call the C routine since it is  most likely
 * and error and we havent put in error checks yet.
 */

	.globl	_qget
_qget:
	Profile
	movl	-4(r6),r1	# put indicator in r1
	movl	-8(r6),r0	# and atom into r0
	jeql	nilpli		# jump if atom is nil
	ashl	$-9,r0,r2	# check type
	cmpb	_typetable+1[r2],$1 # is it a symbol??
	jneq	notsymb		# nope
	movl	4(r0),r0	# yes, put prop list in r1 to begin scan
	jeql	fail		# if no prop list, we lose right away
lp:	cmpl	r1,4(r0)	# is car of list eq to indicator?
	jeql	good		# jump if so
	movl	*(r0),r0	# else cddr down list
	jneq	lp		# and jump if more list to go.

fail:	subl2	$8,NP		# unstack args
	rsb			# return with r0 eq to nil

good:	movl	(r0),r0		# return cadr of list
	movl	4(r0),r0
	subl2	$8,NP		#unstack args
	rsb

nilpli:	movl	_lispsys+64*4,r0 # want nil prop list, get it specially
	jneq	lp		# and process if anything there
	subl2	$8,NP		#unstack args
	rsb			# else fail
	
notsymb:
#ifdef PORTABLE
	movl	r6,NP
	movab	-8(r6),LBOT	# must set up LBOT before calling
#else
	movab	-8(r6),LBOT	# must set up LBOT before calling
#endif
	calls	$0,_Lget	# not a symbol, call C routine to error check
	subl2	$8,NP		#unstack args
	rsb			# and return what it returned.

/*
 * _qexarith 	exact arithmetic
 * calculates x=a*b+c  where a,b and c are 32 bit 2's complement integers
 * whose top two bits must be the same (i.e. the are members of the set
 * of valid fixnum values for Franz Lisp).  The result, x, will be 64 bits
 * long but since each of a, b and c had only 31 bits of precision, the
 * result x only has 62 bits of precision.  The lower 30 bits are returned
 * in *plo and the high 32 bits are returned in *phi.  If *phi is 0 or -1 then
 * x doesn't need any more than 31 bits plus sign to describe, so we
 * place the sign in the high two bits of *plo and return 0 from this
 * routine.  A non zero return indicates that x requires more than 31 bits
 * to describe.
 */

	.globl	_qexarith
/* qexarith(a,b,c,phi,plo)
 * int *phi, *plo;
 */
_qexarith:
	emul	4(sp),8(sp),12(sp),r2   #r2 = a*b + c to 64 bits
	extzv	$0,$30,r2,*20(sp)	#get new lo
	extv	$30,$32,r2,r0		#get new carry
	beql	out			# hi = 0, no work necessary
	movl	r0,*16(sp)		# save hi
	mcoml	r0,r0			# Is hi = -1 (it'll fit in one word)
	bneq	out			# it doesn't
	bisl2	$0xc0000000,*20(sp)	# alter low so that it is ok.
out:	rsb



/*
 * pushframe : stack a frame 
 * When this is called, the optional arguments and class have already been
 * pushed on the stack as well as the return address (by virtue of the jsb)
 * , we push on the rest of the stuff (see h/frame.h)
 * for a picture of the save frame
 */
	.globl	_qpushframe

_qpushframe:
	Profile
	movl	_errp,-(sp)
	movl	_bnp,-(sp)
	movl	NP,-(sp)
	movl	LBOT,-(sp)
	pushr	$0x3f00		# save r13(fp), r12(ap),r11,r10,r9,r8
	movab	6*4(sp),r0	# return addr of lbot on stack
	clrl	_retval		# set retval to C_INITIAL
#ifndef SPISFP
	jmp	*40(sp)		# return through return address
#else
	movab	-4(sp),sp
	movl	sp,(sp)
	movl	_xsp,-(sp)
	jmp	*48(sp)
#endif

/*
 * Ipushf : stack a frame, where space is preallocated on the stack. 
 * this is like pushframe, except that it doesn't alter the stack pointer
 * and will save more registers.
 * This might be written a little more quickly by having a bigger register
 * save mask, but this is only supposed to be an example for the
 * IBM and RIDGE people.
 */

#ifdef SPISFP
	.globl	_Ipushf
_Ipushf:
	.word	0
	addl3	$96,16(ap),r1
	movl	12(ap),-(r1)
	movl	8(ap),-(r1)
	movl	4(ap),-(r1)
	movl	16(fp),-(r1)
	movl	_errp,-(r1)
	movl	_bnp,-(r1)
	movl	NP,-(r1)
	movl	LBOT,-(r1)
	movl	r1,r0
	movq	8(fp),-(r1) /* save stuff in the same order unix saves them
			 (r13,r12,r11,r10,r9,r8) and then add extra
			 for vms (sp,r7,r6,r5,r4,r3,r2) */
	movq	r10,-(r1)
	movq	r8,-(r1)
	movab	20(ap),-(r1) /* assumes Ipushf allways called by calls, with
				the stack alligned */
	movl	_xsp,-(r1)
	movq	r6,-(r1)
	movq	r4,-(r1)
	movq	r2,-(r1)
	clrl	_retval
	ret
#endif
/*
 * qretfromfr
 * called with frame to ret to in r11.  The popnames has already been done.
 * we must restore all registers, and jump to the ret addr. the popping
 * must be done without reducing the stack pointer since an interrupt
 * could come in at any time and this frame must remain on the stack.
 * thus we can't use popr.
 */

	.globl	_qretfromfr

_qretfromfr:
	Profile
	movl	r11,r0		# return error frame location
	subl3	$24,r11,sp	# set up sp at bottom of frame
	movl	sp,r1		# prepare to pop off
	movq	(r1)+,r8	# r8,r9
	movq	(r1)+,r10	# r10,r11
	movq	(r1)+,r12	# r12,r13
	movl	(r1)+,LBOT	# LBOT (lbot)
	movl	(r1)+,NP	# NP (np)
	jmp	*40(sp)		# jump out of frame

#ifdef SPISFP

/*
 * this is equivalent to qretfro for a native VMS system
 *
 */
	.globl	_Iretfrm
_Iretfrm:
	.word	0
	movl	4(ap),r0	# return error frame location
	movl	r0,r1
	movq	-(r1),ap
	movq	-(r1),r10
	movq	-(r1),r8
	movl	-(r1),sp
	movl	-(r1),_xsp
	movq	-(r1),r6
	movq	-(r1),r4
	movq	-(r1),r2
	movl	r0,r1
	movl	(r1)+,LBOT
	movl	(r1)+,NP
	jmp	*16(r0)
#endif

/*
 * this routine finishes setting things up for dothunk
 * it is code shared to keep the size of c-callable thunks
 * for lisp functions, small.
 */
	.globl	_thcpy
_thcpy:
	movl	(sp),r0
	pushl	ap
	pushl	(r0)+
	pushl	(r0)+
	calls	$4,_dothunk
	ret
/*
 * This routine gets the name of the inital entry point
 * It is here so it can be under ifdef control.
 */
	.globl	_gstart
_gstart:
	.word	0
#if os_vms
	moval	_$$$start,r0
#else
	moval	start,r0
#endif
	ret
	.globl	_proflush
_proflush:
	.word	0
	ret

/*
 * The definition of mcount must be present even when the C code
 * isn't being profiled, since lisp code may reference it.
 */

#ifndef os_vms
.globl	mcount
mcount:
#endif

.globl _mcount
_mcount:

#ifdef PROF
	movl	(r0),r1
	bneq	incr
	movl	_countbase,r1
	beql	return
	addl2	$8,_countbase
	movl	(sp),(r1)+
	movl	r1,(r0)
incr:
	incl	(r1)
return:
#endif
	rsb

	
/* This must be at the end of the file.  If we are profiling, allocate
 * space for the profile buffer
 */
#ifdef PROF
	.data
	.comm	_countbase,4
	.lcomm	prbuf,indx+4
	.text
#endif