0.7.8.42:

        * PUSH, PUSHNEW, POP correctly deal with side effects in a
          symbol macro place
        * Commited patch by Gerd Moellman for the argument evaluation
          order in PUSHNEW

diff --git a/NEWS b/NEWS
index 729a0dc..2c56e94 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1332,6 +1332,10 @@ changes in sbcl-0.7.9 relative to sbcl-0.7.8:
   * fixed reading of (COMPLEX DOUBLE-FLOAT) literals from fasl files
   * fixed bug: :COUNT argument to sequence functions may be negative
   * fixed bug: body of DO-SYMBOLS may contain declarations
+  * fixed bug: PUSHNEW now evaluates its arguments from left to right
+    (reported by Paul F. Dietz, fixed by Gerd Moellman)
+  * fixed bug: PUSH, PUSHNEW and POP now evaluate a place given by a
+    symbol macro only once
 
 planned incompatible changes in 0.7.x:
 * When the profiling interface settles down, maybe in 0.7.x, maybe

diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp
index 4ee0528..8c5235a 100644 (file)
--- a/src/code/early-setf.lisp
+++ b/src/code/early-setf.lisp
@@ -186,54 +186,43 @@ GET-SETF-EXPANSION directly."
   #!+sb-doc
   "Takes an object and a location holding a list. Conses the object onto
   the list, returning the modified list. OBJ is evaluated before PLACE."
-  (if (symbolp place)
-      `(setq ,place (cons ,obj ,place))
-      (multiple-value-bind
-         (dummies vals newval setter getter)
-         (get-setf-method place env)
-       (let ((g (gensym)))
-         `(let* ((,g ,obj)
-                 ,@(mapcar #'list dummies vals)
-                 (,(car newval) (cons ,g ,getter)))
-           ,setter)))))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (let ((g (gensym)))
+      `(let* ((,g ,obj)
+              ,@(mapcar #'list dummies vals)
+              (,(car newval) (cons ,g ,getter)))
+         ,setter))))
 
 (defmacro-mundanely pushnew (obj place &rest keys &environment env)
   #!+sb-doc
   "Takes an object and a location holding a list. If the object is already
   in the list, does nothing. Else, conses the object onto the list. Returns
   NIL. If there is a :TEST keyword, this is used for the comparison."
-  (if (symbolp place)
-      `(setq ,place (adjoin ,obj ,place ,@keys))
-      (multiple-value-bind (dummies vals newval setter getter)
-         (get-setf-method place env)
-       (do* ((d dummies (cdr d))
-             (v vals (cdr v))
-             (let-list nil))
-            ((null d)
-             (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
-                   let-list)
-             `(let* ,(nreverse let-list)
-                ,setter))
-         (push (list (car d) (car v)) let-list)))))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (let ((g (gensym)))
+      `(let* ((,g ,obj)
+              ,@(mapcar #'list dummies vals)
+              (,(car newval) (adjoin ,g ,getter ,@keys)))
+         ,setter))))
 
 (defmacro-mundanely pop (place &environment env)
   #!+sb-doc
   "The argument is a location holding a list. Pops one item off the front
   of the list and returns it."
-  (if (symbolp place)
-      `(prog1 (car ,place) (setq ,place (cdr ,place)))
-      (multiple-value-bind (dummies vals newval setter getter)
-         (get-setf-method place env)
-       (do* ((d dummies (cdr d))
-             (v vals (cdr v))
-             (let-list nil))
-            ((null d)
-             (push (list (car newval) getter) let-list)
-             `(let* ,(nreverse let-list)
-                (prog1 (car ,(car newval))
-                       (setq ,(car newval) (cdr ,(car newval)))
-                       ,setter)))
-         (push (list (car d) (car v)) let-list)))))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-method place env)
+    (do* ((d dummies (cdr d))
+          (v vals (cdr v))
+          (let-list nil))
+         ((null d)
+          (push (list (car newval) getter) let-list)
+          `(let* ,(nreverse let-list)
+             (prog1 (car ,(car newval))
+               (setq ,(car newval) (cdr ,(car newval)))
+               ,setter)))
+      (push (list (car d) (car v)) let-list))))
 
 (defmacro-mundanely remf (place indicator &environment env)
   #!+sb-doc

diff --git a/tests/bug204-test.lisp b/tests/bug204-test.lisp
index c11cda9..a1f0fc6 100644 (file)
--- a/tests/bug204-test.lisp
+++ b/tests/bug204-test.lisp
@@ -2,8 +2,8 @@
 (cl:in-package :cl-user)
 
 (macrolet ((def (x)
-             (push `(:expanded ,x) *bug204-test-status*)
-             `(push `(:called ,',x) *bug204-test-status*)))
+             (pushnew `(:expanded ,x) *bug204-test-status* :test #'equalp)
+             `(pushnew `(:called ,',x) *bug204-test-status* :test #'equalp)))
   (eval-when (:compile-toplevel)
     (def :compile-toplevel))
   (eval-when (:load-toplevel)

diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index e1270e1..0abbdea 100644 (file)
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -55,3 +55,20 @@
 ;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of
 ;;; its first argument
 (assert (not (ignore-errors (ldiff 1 2))))
+
+;;; evaluation order in PUSH, PUSHNEW
+(let ((a (map 'vector #'list '(a b c))))
+  (let ((i 0))
+    (pushnew (incf i) (aref a (incf i)))
+    (assert (equalp a #((a) (b) (1 c))))))
+
+(symbol-macrolet ((s (aref a (incf i))))
+    (let ((a (map 'vector #'list '(a b c))))
+      (let ((i 0))
+        (push t s)
+        (assert (equalp a #((a) (t b) (c))))
+        (pushnew 1 s)
+        (assert (equalp a #((a) (t b) (1 c))))
+        (setq i 0)
+        (assert (eql (pop s) 't))
+        (assert (equalp a #((a) (b) (1 c)))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 354881e..c688b7e 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.8.41"
+"0.7.8.42"