mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-02 23:50:56 -08:00
Code Issues Projects Releases Packages Wiki Activity

* DEFSETF now works with functions that take keword arguments. For instance,

Browse source 
(DEFSETF XY (&KEY X Y) (STORE) ...).
* GET-SETF-EXPANSION now avoids generating temporary variables for immediate
  values, such as keywords and integers.
This commit is contained in:
jjgarcia 2002-05-13 07:22:06 +00:00
parent 7c142461af
commit acae405641
1 changed files with 53 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

115
src/lsp/setf.lsp
View file

@ -38,17 +38,21 @@ by (documentation 'SYMBOL 'setf)."
,@(si::expand-set-documentation access-fn 'setf (cadr rest))
',access-fn))
(t
(unless (= (list-length (cadr rest)) 1)
(error "(store-variable) expected."))
(setq rest `(lambda ,(car rest) #'(lambda ,(cadr rest) ,@(cddr rest))))
`(eval-when (compile load eval)
(sys:putprop ',access-fn #',rest 'SETF-LAMBDA)
(remprop ',access-fn 'SETF-UPDATE-FN)
(remprop ',access-fn 'SETF-METHOD)
(remprop ',access-fn 'SETF-SYMBOL)
,@(si::expand-set-documentation access-fn 'setf
(find-documentation (cddr rest)))
',access-fn))))
(let* ((store (second rest))
(args (first rest))
(body (cddr rest))
(doc (find-documentation body)))
(unless (and (= (list-length store) 1) (symbolp (first store)))
(error "Single store-variable expected."))
(setq rest `(lambda ,args #'(lambda ,store ,@body)))
`(eval-when (compile load eval)
(sys:putprop ',access-fn #'(lambda (,@store ,@args) ,@body)
'SETF-LAMBDA)
(remprop ',access-fn 'SETF-UPDATE-FN)
(remprop ',access-fn 'SETF-METHOD)
(remprop ',access-fn 'SETF-SYMBOL)
,@(si::expand-set-documentation access-fn 'setf doc)
',access-fn)))))
;;; DEFINE-SETF-METHOD macro.
@ -107,60 +111,47 @@ Checks if the third gang is a single-element list."
;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
(defun get-setf-method-multiple-value (form &optional env &aux tem)
(defun get-setf-method-multiple-value (form &optional env &aux f)
"Args: (form)
Returns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.
Does not check if the third gang is a single-element list."
(cond ((symbolp form)
(let ((store (gensym)))
(values nil nil (list store) `(setq ,form ,store) form)))
((or (not (consp form)) (not (symbolp (car form))))
(error "Cannot get the setf-method of ~S." form))
((and env (setq tem (assoc (car form) (cdr env))))
(setq tem (macroexpand form env))
(when (eq form tem)
(error "Cannot get setf-method for ~a" form))
(return-from get-setf-method-multiple-value
(get-setf-method-multiple-value tem env)))
((get (car form) 'SETF-METHOD)
(apply (get (car form) 'SETF-METHOD) env (cdr form)))
((or (get (car form) 'SETF-UPDATE-FN)
(setq tem (get (car form) 'STRUCTURE-ACCESS)))
(let ((vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
(cdr form)))
(store (gensym)))
(values vars (cdr form) (list store)
(if tem
(setf-structure-access (car vars) (car tem)
(cdr tem) store)
`(,(get (car form) 'SETF-UPDATE-FN)
,@vars ,store))
(cons (car form) vars))))
((get (car form) 'SETF-LAMBDA)
(let* ((vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
(cdr form)))
(store (gensym))
(f (get (car form) 'SETF-LAMBDA)))
(values vars (cdr form) (list store)
(funcall (apply f vars) store)
(cons (car form) vars))))
((macro-function (car form))
(get-setf-method-multiple-value (macroexpand form)))
(t
(let ((vars (mapcar #'(lambda (x)
(declare (ignore x))
(gensym))
(cdr form)))
(store (gensym)))
(values vars (cdr form) (list store)
;; use the symbol here, otherwise the CLOS walker punts.
`(,(si::setf-namep (list 'SETF (car form))) ,store ,@vars)
(cons (car form) vars))))))
(flet ((rename-arguments (vars &aux names values all-args)
(dolist (item vars)
(unless (or (fixnump item) (keywordp item))
(push item values)
(setq item (gensym))
(push item names))
(push item all-args))
(values (gensym) (nreverse names) (nreverse values) (nreverse all-args))))
(cond ((symbolp form)
(let ((store (gensym)))
(values nil nil (list store) `(setq ,form ,store) form)))
((or (not (consp form)) (not (symbolp (car form))))
(error "Cannot get the setf-method of ~S." form))
((and env (setq f (assoc (car form) (cdr env))))
(setq f (macroexpand form env))
(when (eq form f)
(error "Cannot get setf-method for ~a" form))
(return-from get-setf-method-multiple-value
(get-setf-method-multiple-value f env)))
((macro-function (car form))
(get-setf-method-multiple-value (macroexpand form)))
((setq f (get (car form) 'SETF-METHOD))
(apply f env (cdr form)))
(t
(let ((name (car form)) writer)
(multiple-value-bind (store vars inits all)
(rename-arguments (cdr form))
(setq writer
(cond ((setq f (get name 'SETF-UPDATE-FN))
`(,f ,@all ,store))
((setq f (get name 'STRUCTURE-ACCESS))
(setf-structure-access (car all) (car f) (cdr f) store))
((setq f (get (car form) 'SETF-LAMBDA))
(apply f store all))
(t
`(,(si::setf-namep (list 'SETF name)) ,store ,@all))))
(values vars inits (list store) writer (cons name all))))))))
;;;; SETF definitions.