Commit 21001237 authored by Marius Gerbershagen's avatar Marius Gerbershagen
Browse files

define-setf-expander: fix lambda-list handling

define-setf-expander takes a macro lambda-list. Previously, we handled
the &environment part of this list manually, but &body, &whole
parameters and destructuring did not work.

To fix this, we use sys::expand-defmacro in define-setf-expander. This
necessitates a change in the arguments of the setf-methods stored by
do-define-setf-function: we now pass the whole form (including the
name of the access-function) in the first argument and the environment
in the second argument, like in an ordinary macro function.

Fixes #627.
parent 2a144148
......@@ -102,7 +102,7 @@
(multiple-value-bind (reqs opts rest key-flag keys allow-other-keys auxs)
vl (case context
((defmacro define-compiler-macro)
((defmacro define-compiler-macro define-setf-expander)
(otherwise 'destructuring-bind)))
(let* ((pointer (tempsym))
......@@ -120,7 +120,7 @@
(eq (caadr ,whole) 'cl:function))
(cddr (truly-the cons ,whole))
(cdr (truly-the cons ,whole))))
((defmacro define-setf-expander)
`(cdr (truly-the cons ,whole)))
(otherwise whole)))
(dolist (v (cdr reqs))
......@@ -250,7 +250,8 @@
(values (if decls `((declare ,@decls)) nil)
body doc)))
;; Optional argument context can be 'cl:define-compiler-macro or 'cl:defmacro (default)
;; Optional argument context can be 'cl:define-setf-expander,
;; 'cl:define-compiler-macro or 'cl:defmacro (default)
(defun sys::expand-defmacro (name vl body &optional (context 'cl:defmacro))
(multiple-value-bind (decls body doc)
(find-declarations body)
......@@ -49,9 +49,9 @@
`(,function ,@args ,store))
(do-define-setf-method access-fn
#'(lambda (env &rest args)
#'(lambda (args env)
(declare (ignore env))
(do-setf-method-expansion access-fn function args stores-no)))))
(do-setf-method-expansion access-fn function (cdr args) stores-no)))))
(defun do-define-setf-method (access-fn function)
(declare (type-assertions nil))
......@@ -116,21 +116,11 @@ expanded into
The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved
(let ((env (member '&environment args :test #'eq)))
(if env
(setq args (cons (second env)
(nconc (ldiff args env) (cddr env))))
(setq env (gensym))
(setq args (cons env args))
(push `(declare (ignore ,env)) body))))
(multiple-value-bind (decls body documentation)
(find-declarations body t)
(multiple-value-bind (function pprint documentation)
(sys::expand-defmacro access-fn args body 'define-setf-expander)
(declare (ignore pprint))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(do-define-setf-method ',access-fn
#'(lambda ,args
(block ,access-fn ,@body)))
(do-define-setf-method ',access-fn #',function)
,@(si::expand-set-documentation access-fn 'setf documentation)
......@@ -152,7 +142,7 @@ Does not check if the third gang is a single-element list."
((or (not (consp form)) (not (symbolp (car form))))
(error "Cannot get the setf-method of ~S." form))
((setq f (get-sysprop (car form) 'SETF-METHOD))
(apply f env (cdr form)))
(funcall f form env))
((and (setq f (macroexpand-1 form env)) (not (equal f form)))
(get-setf-expansion f env))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment