99 |
|
|
100 |
;;;; GET-SETF-METHOD-MULTIPLE-VALUE. |
;;;; GET-SETF-METHOD-MULTIPLE-VALUE. |
101 |
|
|
102 |
|
;; FIXME when all is well, remove this and the setf tests in the pcl directory |
103 |
|
(push 'setf *features*) |
104 |
|
|
105 |
(defun get-setf-method-multiple-value (form &optional env &aux tem) |
(defun get-setf-method-multiple-value (form &optional env &aux tem) |
106 |
(cond ((symbolp form) |
(cond ((symbolp form) |
107 |
(let ((store (gensym))) |
(let ((store (gensym))) |
144 |
(cons (car form) vars)))) |
(cons (car form) vars)))) |
145 |
((macro-function (car form)) |
((macro-function (car form)) |
146 |
(get-setf-method-multiple-value (macroexpand form))) |
(get-setf-method-multiple-value (macroexpand form))) |
147 |
(t |
(t |
148 |
(error "Cannot expand the SETF form ~S." form)))) |
(let ((vars (mapcar #'(lambda (x) |
149 |
|
(declare (ignore x)) |
150 |
|
(gensym)) |
151 |
|
(cdr form))) |
152 |
|
(store (gensym))) |
153 |
|
(values vars (cdr form) (list store) |
154 |
|
`(funcall |
155 |
|
#'(setf ,(car form)) |
156 |
|
,store ,@vars ) |
157 |
|
(cons (car form) vars)))))) |
158 |
|
|
159 |
|
|
160 |
;;;; SETF definitions. |
;;;; SETF definitions. |
384 |
(defun setf-helper (rest env) |
(defun setf-helper (rest env) |
385 |
(setq rest (cdr rest)) |
(setq rest (cdr rest)) |
386 |
(cond ((endp rest) nil) |
(cond ((endp rest) nil) |
387 |
((endp (cdr rest)) (error "~S is an illegal SETF form." rest)) |
; ((endp (cdr rest)) (error "~S is an illegal SETF form." rest)) |
388 |
((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env)) |
((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env)) |
389 |
(t (cons 'progn (setf-expand rest env))))) |
(t (cons 'progn (setf-expand rest env))))) |
390 |
|
|