.asciz "@(#)qfuncl.s 34.1 10/3/80"
# opus 30 compiler call to ??? interface routines
__qfuncl: # quick function call
# movab qfunbuf,r0 # profiling
cmpl r6,_nplim # make sure stack ok
on1: movl (r7),r0 # bring in addr of atom
addl2 $4,r7 # inc lbot by one nament
pushl r0 # stack addr of atom of fcn to call
movl 8(r0),r0 # bring in fcn binding addr
jleq nonexf # jump if fcn non existant
tstl _rsetsw # see if in *rset mode
jeql norset # if not, call function
tstl _bcdtrsw # if (*rset t) & (sstatus bcdtrace t)
jneq hackit # then have Lfuncal do the work
ashl $-9,r0,r1 # see if bcd
cmpb $5,_typetable+1[r1] # we are calling
calls $1,_Lfuncal # call lisp stuff
movab -4(r7),r6 # restore np to top
calls $1,*(r0) # call code
movab -4(r7),r6 # restore np to top
nonexf: # non existant function, call c function to take care of it,
# we could process it here but wish to minimize assembly language
# we should never return from this call
# the addr of the atom is already stacked
# addl2 $4,r7 # inc lbot by one nament for evalframe
calls $1,_Undeff # call handler
clrl r0 # return nil to compiled code
rsb # if ever should return here
# transfer table linkage routine
.word 0xfc0 # save all possible registers
# movab qlinbuf,r0 # profiling
tstl _exception # any pending exceptions
tstl _sigintcnt # is it because of SIGINT
jeql noexc # if not, just leave
pushl $2 # else push SIGINT
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 8(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
jeql linkin # bcd, link it in!
pushl r1 # non, bcd, call interpreter
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 r1 # non existant fcn
calls $1,_Undeff # call processor
jbr retry # for the retry.
.globl __erthrow # errmessage for uncaught throws
.byte 'U,'n,'c,'a,'u,'g,'h,'t,' ,'t,'h,'r,'o,'w
.byte ' ,'f,'r,'o,'m,' ,'c,'o,'m,'p,'i,'l,'e,'d
.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+83*4 # port_name
.long _lispsys+47*4 # array_name
.long _lispsys+50*4 # sdot_name
.long _lispsys+53*4 # val_nam
# Quickly allocate small fixnums
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.
# quick cons call, the car and cdr are stacked on the namestack
# and this function is jsb'ed to.
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
getnew: calls $0,_newdot # must gc to get one
jbr storit # now initialize it.
# Fast equivalent of newdot, entered by jsb
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
_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
subl2 $8,r2 # for(; (--r2) > r1;) {
cmpl r2,r1 # test for done
movl (r2),*4(r2) # r2->atm->a.clb = r2 -> val;
movl r1,_bnp # restore bnp
# _qget : fast get subroutine
# called with -8(r6) equal to the atom
# -4(r6) equal to the indicator
# no assumption is made about r7
# 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.
qgtbf: .word 0 # for profiling
# movab qgtbf,r0 # these instructions are for profiling
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??
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?
movl *(r0),r0 # else cddr down list
jneq lp # and jump if more list to go.
fail: subl2 $8,r6 # unstack args
rsb # return with r0 eq to nil
good: movl (r0),r0 # return cadr of list
subl2 $8,r6 #unstack args
nilpli: movl _lispsys+64*4,r0 # want nil prop list, get it specially
jneq lp # and process if anything there
subl2 $8,r6 #unstack args
movab -8(r6),r7 # must set up r7 before calling
calls $0,_Lget # not a symbol, call C routine to error check
subl2 $8,r6 #unstack args
rsb # and return what it returned.
projects / unix-history / blob