Skip to content

Commit

Permalink
fix interpretation of defsetf lambda lists
Browse files Browse the repository at this point in the history
* lib/setf.lisp: (defsetf) use CCL::%DESTRUCTURE-LAMBDA-LIST instead
of CCL::RENAME-LAMBDA-VARS to come up with a suitable setf
expansion.

https://lists.clozure.com/pipermail/openmcl-devel/2020-September/012217.html

Currently CCL does not expand defsetf lambda lists of the form
(defsetf get-foo (&key (add1 1) (add2 (+ add1 2)))
	 (data)
 `(setq $foo (- ,data ,add1 ,add2)))
(get-setf-expansion '(get-foo))
;; => The value #:ADD1 is not of the expected type NUMBER.

WIP. This patch tries to rectify that. With this patch

(setf (get-foo) 10) ;; should return 6

The patch is for review and doesn't fix indentation and involved the
use of of an unhygenic EXPRESSION symbol. This is to facilitate easy
review.
  • Loading branch information
Madhu committed Sep 27, 2020
1 parent 8778079 commit 2e08d57
Showing 1 changed file with 13 additions and 10 deletions.
23 changes: 13 additions & 10 deletions lib/setf.lisp
Original file line number Diff line number Diff line change
Expand Up @@ -216,8 +216,9 @@
(unless (verify-lambda-list lambda-list)
(signal-program-error $XBadLambdaList lambda-list))
(let* ((store-vars (cons store-var mv-store-vars)))
(multiple-value-bind (lambda-list lambda-temps lambda-vars)
(rename-lambda-vars lambda-list)
(multiple-value-bind (bindings lambda-temps)
(%destructure-lambda-list lambda-list 'expression nil nil :use-whole-var t)
(setq bindings (nreverse bindings))
(multiple-value-bind (body decls doc)
(parse-body body env t)
(setq body `((block ,access-fn ,@body)))
Expand All @@ -234,25 +235,27 @@
',access-fn
#'(lambda (,access-form ,environment)
(declare (ignore ,environment))
(do* ((,args (cdr ,access-form) (cdr ,args))
(do* ((expression (cdr ,access-form))
(,args (cdr ,access-form) (cdr ,args))
(,dummies nil (cons (gensym) ,dummies))
(,newval-vars (mapcar #'(lambda (v) (declare (ignore v)) (gensym)) ',store-vars))
(,new-access-form nil))
((atom ,args)
(let* ,bindings
,@(when lambda-temps `((declare ,@lambda-temps))) ; preserving bogus bug
(setq ,new-access-form
(cons (car ,access-form) ,dummies))
(destructuring-bind ,(append lambda-vars store-vars )
`,(append ',lambda-temps ,newval-vars)
(destructuring-bind ,(append store-vars )
`,(append ,newval-vars)
,@decls
(values
,dummies
(cdr ,access-form)
,newval-vars
`((lambda ,,lambda-list
,',@ignorable
,,@body)
,@,dummies)
,new-access-form))))))
`(apply (lambda ,',(mapcar 'car bindings)
,,@body)
'(,,@(mapcar 'cadr bindings)))
,new-access-form)))))))
,@(if doc (list doc))
',access-fn))))))))

Expand Down

0 comments on commit 2e08d57

Please sign in to comment.