defsetf: change DO-DEFSETF function prototype

Carry STORES to do-setf-method-expansion in order to fix bug with long
form of DEFSETF (using multiple values as assignment variables is
legal). Change is backwards compatible.

CHANGELOG

@@ -30,6 +30,10 @@
 * Pending changes since 16.0.0
 ** API changes
 
+   - si:do-setf accepts optional parameter stores.  New lambda-list:
+     =(access-fn function &optional (stores `(,(gensym))))=
+     This change is backward compatible.
+
    - New MP functions:
      mp:with-rwlock
      mp:try-get-semaphore (non-blocking)

src/c/symbols_list.h

@@ -2214,7 +2214,7 @@ cl_symbols[] = {
 
 {SYS_ "REPORT-FUNCTION", SI_ORDINARY, NULL, -1, OBJNULL},
 
-{SYS_ "DO-DEFSETF", SI_ORDINARY, ECL_NAME(si_do_defsetf), 2, OBJNULL},
+{SYS_ "DO-DEFSETF", SI_ORDINARY, ECL_NAME(si_do_defsetf), -1, OBJNULL},
 {SYS_ "DO-DEFINE-SETF-METHOD", SI_ORDINARY, ECL_NAME(si_do_define_setf_method), 2, OBJNULL},
 
 {SYS_ "SETF-DEFINITION", SI_ORDINARY, ECL_NAME(si_setf_definition), 2, OBJNULL},

src/cmp/proclamations.lsp

@@ -191,7 +191,7 @@
 
 ;; ECL extensions:
 (proclamation si:specialp (symbol) gen-bool :predicate)
-(proclamation si::do-defsetf (symbol (or symbol function)) t)
+(proclamation si::do-defsetf (symbol (or symbol function) &optional list) t)
 (proclamation si::do-define-setf-method (symbol function) t)
 (proclamation ext:constant-form-value (t &optional environment) t)
 (proclamation ext:constantp-inner (t &optional environment) gen-bool)

src/h/external.h

@@ -2065,7 +2065,7 @@ extern ECL_API cl_object si_ratiop(cl_object t);
 
 /* setf.lsp */
 
-extern ECL_API cl_object si_do_defsetf(cl_object name, cl_object function);
+extern ECL_API cl_object si_do_defsetf _ECL_ARGS ((cl_narg narg, cl_object name, cl_object function, ...));
 extern ECL_API cl_object si_do_define_setf_method(cl_object name, cl_object function);
 
 /* seq.lsp */

src/lsp/setf.lsp

@@ -18,7 +18,7 @@
 
 (in-package "SYSTEM")
 
-(defun do-setf-method-expansion (name lambda args)
+(defun do-setf-method-expansion (name lambda args stores)
   (declare (si::c-local))
   (let* ((vars '())
          (inits '())
@@ -29,24 +29,26 @@
         (setq item (gensym))
         (push item vars))
       (push item all))
-    (let* ((store (gensym))
-           (all (nreverse all)))
+    (let* ((all (nreverse all)))
       (values (nreverse vars)
               (nreverse inits)
-              (list store)
+              stores
               (if lambda
-                  (apply lambda store all)
-                  `(funcall #'(setf ,name) ,store ,@all))
+                  (apply lambda (append stores all))
+                  `(funcall #'(setf ,name) ,@stores ,@all))
               (cons name all)))))
 
-(defun do-defsetf (access-fn function)
+(defun do-defsetf (access-fn function &optional (stores `(,(gensym))))
   (declare (type-assertions nil))
   (if (symbolp function)
-      (do-defsetf access-fn #'(lambda (store &rest args) `(,function ,@args ,store)))
+      (do-defsetf access-fn
+        #'(lambda (store &rest args)
+            `(,function ,@args ,store))
+        stores)
       (do-define-setf-method access-fn
         #'(lambda (env &rest args)
             (declare (ignore env))
-            (do-setf-method-expansion access-fn function args)))))
+            (do-setf-method-expansion access-fn function args stores)))))
 
 (defun do-define-setf-method (access-fn function)
   (declare (type-assertions nil))
@@ -139,7 +141,7 @@ Does not check if the third gang is a single-element list."
         ((and (setq f (macroexpand-1 form env)) (not (equal f form)))
          (get-setf-expansion f env))
         (t
-         (do-setf-method-expansion (car form) nil (cdr form)))))
+         (do-setf-method-expansion (car form) nil (cdr form) `(,(gensym))))))
 
 ;;;; SETF definitions.