![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to qfuncl.s CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 40BSD / cmd / lisp|
Return to qfuncl.s CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 ! root 1: ! 2: .asciz "@(#)qfuncl.s 34.1 10/3/80" ! 3: # opus 30 compiler call to ??? interface routines ! 4: .globl __qf0 ! 5: __qf0: ! 6: subl3 $4,r6,r7 ! 7: jbr __qfuncl ! 8: ! 9: .globl __qf1 ! 10: __qf1: ! 11: subl3 $8,r6,r7 ! 12: jbr __qfuncl ! 13: ! 14: .globl __qf2 ! 15: __qf2: ! 16: subl3 $12,r6,r7 ! 17: jbr __qfuncl ! 18: ! 19: .globl __qf3 ! 20: __qf3: ! 21: subl3 $16,r6,r7 ! 22: jbr __qfuncl ! 23: ! 24: .globl __qf4 ! 25: __qf4: ! 26: subl3 $20,r6,r7 ! 27: jbr __qfuncl ! 28: ! 29: .data ! 30: qfunbuf: .long 0 ! 31: qlinbuf: .long 0 ! 32: .text ! 33: .globl __qfuncl ! 34: __qfuncl: # quick function call ! 35: # movab qfunbuf,r0 # profiling ! 36: # jsb mcount # profiling ! 37: cmpl r6,_nplim # make sure stack ok ! 38: blss on1 ! 39: calls $0,_namerr ! 40: on1: movl (r7),r0 # bring in addr of atom ! 41: addl2 $4,r7 # inc lbot by one nament ! 42: pushl r0 # stack addr of atom of fcn to call ! 43: movl 8(r0),r0 # bring in fcn binding addr ! 44: jleq nonexf # jump if fcn non existant ! 45: tstl _rsetsw # see if in *rset mode ! 46: jeql norset # if not, call function ! 47: tstl _bcdtrsw # if (*rset t) & (sstatus bcdtrace t) ! 48: jneq hackit # then have Lfuncal do the work ! 49: norset: ! 50: ashl $-9,r0,r1 # see if bcd ! 51: cmpb $5,_typetable+1[r1] # we are calling ! 52: jeql gotbcd ! 53: hackit: ! 54: calls $1,_Lfuncal # call lisp stuff ! 55: movab -4(r7),r6 # restore np to top ! 56: rsb # return to callee ! 57: gotbcd: ! 58: calls $1,*(r0) # call code ! 59: movab -4(r7),r6 # restore np to top ! 60: rsb # return ! 61: ! 62: nonexf: # non existant function, call c function to take care of it, ! 63: # we could process it here but wish to minimize assembly language ! 64: # code. ! 65: # we should never return from this call ! 66: # the addr of the atom is already stacked ! 67: ! 68: # addl2 $4,r7 # inc lbot by one nament for evalframe ! 69: calls $1,_Undeff # call handler ! 70: clrl r0 # return nil to compiled code ! 71: rsb # if ever should return here ! 72: ! 73: ! 74: ! 75: # transfer table linkage routine ! 76: # ! 77: .globl _qlinker ! 78: _qlinker: ! 79: .word 0xfc0 # save all possible registers ! 80: # movab qlinbuf,r0 # profiling ! 81: # jsb mcount # profiling ! 82: tstl _exception # any pending exceptions ! 83: jeql noexc ! 84: tstl _sigintcnt # is it because of SIGINT ! 85: jeql noexc # if not, just leave ! 86: pushl $2 # else push SIGINT ! 87: calls $1,_sigcall ! 88: noexc: ! 89: movl 16(fp),r0 # get return pc ! 90: addl2 -4(r0),r0 # get pointer to table ! 91: movl 4(r0),r1 # get atom pointer ! 92: retry: # come here after undef func error ! 93: movl 8(r1),r2 # get function binding ! 94: jleq nonex # if none, leave ! 95: tstl _stattab+2*4 # see if linking possible (Strans) ! 96: jeql nolink # no, it isn't ! 97: ashl $-9,r2,r3 # check type of function ! 98: cmpb $5,_typetable+1[r3] ! 99: jeql linkin # bcd, link it in! ! 100: nolink: ! 101: pushl r1 # non, bcd, call interpreter ! 102: calls $1,_Lfuncal ! 103: ret ! 104: ! 105: linkin: ! 106: ashl $-9,4(r2),r3 # check type of function discipline ! 107: cmpb $0,_typetable+1[r3] # is it string? ! 108: jeql nolink # yes, it is a c call, so dont link in ! 109: movl (r2),r2 # get function addr ! 110: movl r2,(r0) # put fcn addr in table ! 111: jmp 2(r2) # enter fcn after mask ! 112: ! 113: nonex: pushl r1 # non existant fcn ! 114: calls $1,_Undeff # call processor ! 115: movl r0,r1 # back in r1 ! 116: jbr retry # for the retry. ! 117: ! 118: ! 119: .globl __erthrow # errmessage for uncaught throws ! 120: __erthrow: ! 121: .byte 'U,'n,'c,'a,'u,'g,'h,'t,' ,'t,'h,'r,'o,'w ! 122: .byte ' ,'f,'r,'o,'m,' ,'c,'o,'m,'p,'i,'l,'e,'d ! 123: .byte ' ,'c,'o,'d,'e,0 ! 124: ! 125: .globl _tynames ! 126: _tynames: ! 127: .long 0 # nothing here ! 128: .long _lispsys+20*4 # str_name ! 129: .long _lispsys+21*4 # atom_name ! 130: .long _lispsys+19*4 # int_name ! 131: .long _lispsys+23*4 # dtpr_name ! 132: .long _lispsys+22*4 # doub_name ! 133: .long _lispsys+58*4 # funct_name ! 134: .long _lispsys+83*4 # port_name ! 135: .long _lispsys+47*4 # array_name ! 136: .long 0 # nothing here ! 137: .long _lispsys+50*4 # sdot_name ! 138: .long _lispsys+53*4 # val_nam ! 139: # ! 140: # Quickly allocate small fixnums ! 141: # ! 142: .globl _qnewint ! 143: _qnewint: ! 144: cmpl r5,$1024 ! 145: jgeq alloc ! 146: cmpl r5,$-1024 ! 147: jlss alloc ! 148: moval Fixzero[r5],r0 ! 149: rsb ! 150: alloc: ! 151: movl _int_str,r0 # move next cell addr to r0 ! 152: jlss callnewi # if no space, allocate ! 153: incl *_lispsys+24*4 # inc count of ints ! 154: movl (r0),_int_str # advance free list ! 155: movl r5,(r0) # put baby to bed. ! 156: rsb ! 157: callnewi: ! 158: pushl r5 ! 159: calls $0,_newint ! 160: movl (sp)+,(r0) ! 161: rsb ! 162: .globl _qcons ! 163: ! 164: # quick cons call, the car and cdr are stacked on the namestack ! 165: # and this function is jsb'ed to. ! 166: ! 167: _qcons: ! 168: movl _dtpr_str,r0 # move next cell addr to r0 ! 169: jlss getnew # if ran out of space jump ! 170: incl *_lispsys+28*4 # inc count of dtprs ! 171: movl (r0),_dtpr_str # advance free list ! 172: storit: movl -(r6),(r0) # store in cdr ! 173: movl -(r6),4(r0) # store in car ! 174: rsb ! 175: ! 176: getnew: calls $0,_newdot # must gc to get one ! 177: jbr storit # now initialize it. ! 178: ! 179: # ! 180: # Fast equivalent of newdot, entered by jsb ! 181: # ! 182: .globl _qnewdot ! 183: _qnewdot: ! 184: movl _dtpr_str,r0 # mov next cell addr t0 r0 ! 185: jlss mustallo # if ran out of space ! 186: incl *_lispsys+28*4 # inc count of dtprs ! 187: movl (r0),_dtpr_str # advance free list ! 188: clrq (r0) ! 189: rsb ! 190: mustallo: ! 191: calls $0,_newdot ! 192: rsb ! 193: .globl _qpopnames ! 194: _qpopnames: # equivalent of C-code popnames, entered by jsb. ! 195: movl (sp)+,r0 # return address ! 196: movl (sp)+,r1 # Lower limit ! 197: movl _bnp,r2 # pointer to bind stack entry ! 198: qploop: ! 199: subl2 $8,r2 # for(; (--r2) > r1;) { ! 200: cmpl r2,r1 # test for done ! 201: jlss qpdone ! 202: movl (r2),*4(r2) # r2->atm->a.clb = r2 -> val; ! 203: brb qploop # } ! 204: qpdone: ! 205: movl r1,_bnp # restore bnp ! 206: jmp (r0) # return ! 207: ! 208: # _qget : fast get subroutine ! 209: # (get 'atom 'ind) ! 210: # called with -8(r6) equal to the atom ! 211: # -4(r6) equal to the indicator ! 212: # no assumption is made about r7 ! 213: # unfortunately, the atom may not in fact be an atom, it may ! 214: # be a list or nil, which are special cases. ! 215: # For nil, we grab the nil property list (stored in a special place) ! 216: # and for lists we punt and call the C routine since it is most likely ! 217: # and error and we havent put in error checks yet. ! 218: # ! 219: .data ! 220: qgtbf: .word 0 # for profiling ! 221: .text ! 222: ! 223: .globl _qget ! 224: _qget: ! 225: # movab qgtbf,r0 # these instructions are for profiling ! 226: # jsb mcount ! 227: movl -4(r6),r1 # put indicator in r1 ! 228: movl -8(r6),r0 # and atom into r0 ! 229: jeql nilpli # jump if atom is nil ! 230: ashl $-9,r0,r2 # check type ! 231: cmpb _typetable+1[r2],$1 # is it a symbol?? ! 232: jneq notsymb # nope ! 233: movl 4(r0),r0 # yes, put prop list in r1 to begin scan ! 234: jeql fail # if no prop list, we lose right away ! 235: lp: cmpl r1,4(r0) # is car of list eq to indicator? ! 236: jeql good # jump if so ! 237: movl *(r0),r0 # else cddr down list ! 238: jneq lp # and jump if more list to go. ! 239: ! 240: fail: subl2 $8,r6 # unstack args ! 241: rsb # return with r0 eq to nil ! 242: ! 243: good: movl (r0),r0 # return cadr of list ! 244: movl 4(r0),r0 ! 245: subl2 $8,r6 #unstack args ! 246: rsb ! 247: ! 248: nilpli: movl _lispsys+64*4,r0 # want nil prop list, get it specially ! 249: jneq lp # and process if anything there ! 250: subl2 $8,r6 #unstack args ! 251: rsb # else fail ! 252: ! 253: notsymb: ! 254: movab -8(r6),r7 # must set up r7 before calling ! 255: calls $0,_Lget # not a symbol, call C routine to error check ! 256: subl2 $8,r6 #unstack args ! 257: rsb # and return what it returned. ! 258:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.