* 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
* 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 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
planned incompatible changes in 0.7.x:
* When the profiling interface settles down, maybe in 0.7.x, maybe
#!+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."
#!+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."
(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."
(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
(defmacro-mundanely remf (place indicator &environment env)
#!+sb-doc
(cl:in-package :cl-user)
(macrolet ((def (x)
(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)
(eval-when (:compile-toplevel)
(def :compile-toplevel))
(eval-when (:load-toplevel)
;;; reported by Paul Dietz on cmucl-imp: LDIFF does not check type of
;;; its first argument
(assert (not (ignore-errors (ldiff 1 2))))
;;; 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)))))))
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)