100 |
(null (get fun 'no-sp-change))))) |
(null (get fun 'no-sp-change))))) |
101 |
(list 'function info (list 'call-global info fun)) |
(list 'function info (list 'call-global info fun)) |
102 |
)))) |
)))) |
103 |
|
;; FIXME centralize this bit |
104 |
|
((and (consp fun) (eq (car fun) 'setf) |
105 |
|
(consp (cdr fun)) (symbolp (cadr fun)) |
106 |
|
(endp (cddr fun))) |
107 |
|
(let ((info (make-info |
108 |
|
:sp-change t))) |
109 |
|
(list 'function info (list 'call-setf info fun)))) |
110 |
((and (consp fun) (eq (car fun) 'lambda)) |
((and (consp fun) (eq (car fun) 'lambda)) |
111 |
(cmpck (endp (cdr fun)) |
(cmpck (endp (cdr fun)) |
112 |
"The lambda expression ~s is illegal." fun) |
"The lambda expression ~s is illegal." fun) |
123 |
(case (car funob) |
(case (car funob) |
124 |
(call-global |
(call-global |
125 |
(unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) |
(unwind-exit (list 'symbol-function (add-symbol (caddr funob))))) |
126 |
|
(call-setf |
127 |
|
(unwind-exit (list 'setf-function (add-symbol (cadr (caddr funob)))))) |
128 |
(call-local |
(call-local |
129 |
(if (cadddr funob) |
(if (cadddr funob) |
130 |
(unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob)))) |
(unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob)))) |
149 |
|
|
150 |
(si:putprop 'symbol-function 'wt-symbol-function 'wt-loc) |
(si:putprop 'symbol-function 'wt-symbol-function 'wt-loc) |
151 |
(si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc) |
(si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc) |
152 |
|
(si:putprop 'setf-function 'wt-setf-function 'wt-loc) |
153 |
|
|
154 |
(defun wt-symbol-function (vv) |
(defun wt-symbol-function (vv) |
155 |
(if *safe-compile* |
(if *safe-compile* |
156 |
(wt "symbol_function(VV[" vv "])") |
(wt "symbol_function(VV[" vv "])") |
157 |
(wt "(VV[" vv "]->s.s_gfdef)"))) |
(wt "(VV[" vv "]->s.s_gfdef)"))) |
158 |
|
|
159 |
|
(defun wt-setf-function (vv) |
160 |
|
; FIXME don't inline all of this |
161 |
|
(wt "({object _tmp=get(VV[" vv "],sSsetf_function,Cnil);") |
162 |
|
(wt "if (_tmp==Cnil) {") |
163 |
|
(wt "int bs=((object)VV[" vv "])->s.s_fillp+8;") |
164 |
|
(wt "char *b=alloca(bs);") |
165 |
|
(wt "snprintf(b,bs,\"(SETF %-.*s)\",bs-8,((object)VV[" vv "])->s.s_self);") |
166 |
|
(wt "FEundefined_function(make_simple_string(b));}") |
167 |
|
(wt "_tmp;})")) |
168 |
|
|
169 |
(defun wt-make-cclosure (cfun clink) |
(defun wt-make-cclosure (cfun clink) |
170 |
(wt-nl "make_cclosure_new(LC" cfun ",Cnil,") |
(wt-nl "make_cclosure_new(LC" cfun ",Cnil,") |
171 |
(wt-clink clink) |
(wt-clink clink) |