From d3a908b19150a1ce739d8ec5daeedcc63da2ef2d Mon Sep 17 00:00:00 2001
From: Madhu <enometh@net.meer>
Date: Sun, 27 Sep 2020 06:35:58 +0530
Subject: [PATCH] fix interpretation of defsetf lambda lists

* 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.
---
 lib/setf.lisp | 23 +++++++++++++----------
 1 file changed, 13 insertions(+), 10 deletions(-)

diff --git a/lib/setf.lisp b/lib/setf.lisp
index 9a8f0e3d6..f3cd7fa21 100644
--- a/lib/setf.lisp
+++ b/lib/setf.lisp
@@ -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)))
@@ -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))))))))