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

CCL did 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.

With this patch
(setf (get-foo) 10) ;; should return 6
  • Loading branch information
Madhu committed Nov 28, 2021
1 parent 110c230 commit e7552a5
Showing 1 changed file with 18 additions and 24 deletions.
42 changes: 18 additions & 24 deletions lib/setf.lisp
Original file line number Diff line number Diff line change
Expand Up @@ -216,16 +216,14 @@
(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 decls2)
(%destructure-lambda-list lambda-list 'expression nil nil :use-whole-var t)
(setq bindings (nreverse bindings) decls2 (nreverse decls2))
(multiple-value-bind (body decls doc)
(parse-body body env t)
(setq body `((block ,access-fn ,@body)))
(let* ((ignorable `((declare (ignorable ,@lambda-temps))))
(args (gensym))
(dummies (gensym))
(let* ((args (gensym))
(newval-vars (gensym))
(new-access-form (gensym))
(access-form (gensym))
(environment (gensym)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
Expand All @@ -234,25 +232,21 @@
',access-fn
#'(lambda (,access-form ,environment)
(declare (ignore ,environment))
(do* ((,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))
(do* ((expression (cdr ,access-form))
(,args (cdr ,access-form) (cdr ,args))
(,newval-vars (mapcar #'(lambda (v) (declare (ignore v)) (gensym)) ',store-vars)))
((atom ,args)
(setq ,new-access-form
(cons (car ,access-form) ,dummies))
(destructuring-bind ,(append lambda-vars store-vars )
`,(append ',lambda-temps ,newval-vars)
,@decls
(values
,dummies
(cdr ,access-form)
,newval-vars
`((lambda ,,lambda-list
,',@ignorable
,,@body)
,@,dummies)
,new-access-form))))))
(destructuring-bind ,(append store-vars )
`,(append ,newval-vars)
(let* ,bindings
,@(when decls2
`((declare ,@decls2)))
,@decls
(values
nil nil
,newval-vars
,@body
,access-form)))))))
,@(if doc (list doc))
',access-fn))))))))

Expand Down

0 comments on commit e7552a5

Please sign in to comment.