![[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.