/[gcl]/gcl/cmpnew/gcl_cmpspecial.lsp
ViewVC logotype

Diff of /gcl/cmpnew/gcl_cmpspecial.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by camm, Sun Sep 14 02:43:01 2003 UTC revision 1.3 by camm, Tue Oct 7 21:06:32 2003 UTC
# Line 100  Line 100 
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)
# Line 116  Line 123 
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))))
# Line 140  Line 149 
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)

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26