From 0c9dcfb55e73398a3df8b1cc26d601b45685f29f Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Thu, 17 Oct 2002 11:04:14 +0000 Subject: [PATCH] 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 --- NEWS | 4 +++ src/code/early-setf.lisp | 63 +++++++++++++++++++--------------------------- tests/bug204-test.lisp | 4 +-- tests/list.pure.lisp | 17 +++++++++++++ version.lisp-expr | 2 +- 5 files changed, 50 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 729a0dc..2c56e94 100644 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4