From: Alexey D. <ade...@us...> - 2002-10-30 14:02:18
|
Update of /cvsroot/sbcl/sbcl/src/code In directory usw-pr-cvs1:/tmp/cvs-serv26893/src/code Modified Files: defboot.lisp list.lisp Log Message: 0.7.9.16: * fixed bugs, reported by Paul Dietz: DOLIST.5, SET-EXCLUSIVE-OR-17, MULTIPLE-VALUE-SETQ.5. * we are not going to release yet another 0.7.9 :-) Index: defboot.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/defboot.lisp,v retrieving revision 1.25 retrieving revision 1.26 diff -u -d -r1.25 -r1.26 --- defboot.lisp 19 Sep 2002 17:26:54 -0000 1.25 +++ defboot.lisp 30 Oct 2002 14:02:11 -0000 1.26 @@ -47,22 +47,9 @@ (error "Vars is not a list of symbols: ~S" vars))) (defmacro-mundanely multiple-value-setq (vars value-form) - (cond ((null vars) - ;; The ANSI spec says that the primary value of VALUE-FORM must be - ;; returned. The general-case-handling code below doesn't do this - ;; correctly in the special case when there are no vars bound, so we - ;; handle this special case separately here. - (let ((g (gensym))) - `(multiple-value-bind (,g) ,value-form - ,g))) - ((list-of-symbols-p vars) - (let ((temps (make-gensym-list (length vars)))) - `(multiple-value-bind ,temps ,value-form - ,@(mapcar (lambda (var temp) - `(setq ,var ,temp)) - vars temps) - ,(car temps)))) - (t (error "Vars is not a list of symbols: ~S" vars)))) + (unless (list-of-symbols-p vars) + (error "Vars is not a list of symbols: ~S" vars)) + `(values (setf (values ,@vars) ,value-form))) (defmacro-mundanely multiple-value-list (value-form) `(multiple-value-call #'list ,value-form)) @@ -336,8 +323,8 @@ (declare (type unsigned-byte ,var)) ,@body)))))) (defmacro-mundanely dolist (var-list-result &body body) - (multiple-value-bind ; to roll our own destructuring - (var list result) + (multiple-value-bind ; to roll our own destructuring + (var list result) (apply (lambda (var list &optional (result nil)) (values var list result)) var-list-result) @@ -347,18 +334,21 @@ ;; form, we introduce a gratuitous binding of the variable to NIL ;; without the declarations, then evaluate the result form in that ;; environment. We spuriously reference the gratuitous variable, - ;; since since we don't want to use IGNORABLE on what might be a - ;; special var. - (let ((n-list (gensym))) - `(do ((,n-list ,list (cdr ,n-list))) - ((endp ,n-list) - ,@(if result - `((let ((,var nil)) - ,var - ,result)) - '(nil))) - (let ((,var (car ,n-list))) - ,@body))))) + ;; since we don't want to use IGNORABLE on what might be a special + ;; var. + (multiple-value-bind (forms decls) (parse-body body nil) + (let ((n-list (gensym))) + `(do* ((,n-list ,list (cdr ,n-list))) + ((endp ,n-list) + ,@(if result + `((let ((,var nil)) + ,var + ,result)) + '(nil))) + (let ((,var (car ,n-list))) + ,@decls + (tagbody + ,@forms))))))) ;;;; miscellaneous @@ -367,7 +357,7 @@ (defmacro-mundanely psetq (&rest pairs) #!+sb-doc - "SETQ {var value}* + "PSETQ {var value}* Set the variables to the values, like SETQ, except that assignments happen in parallel, i.e. no assignments take place until all the forms have been evaluated." Index: list.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/list.lisp,v retrieving revision 1.12 retrieving revision 1.13 diff -u -d -r1.12 -r1.13 --- list.lisp 6 Oct 2001 19:54:38 -0000 1.12 +++ list.lisp 30 Oct 2002 14:02:12 -0000 1.13 @@ -792,17 +792,28 @@ res)) (defun set-exclusive-or (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (test #'eql testp) (test-not nil notp)) #!+sb-doc "Return new list of elements appearing exactly once in LIST1 and LIST2." (declare (inline member)) - (let ((result nil)) + (let ((result nil) + (key (when key (coerce key 'function))) + (test (coerce test 'function)) + (test-not (if test-not (coerce test-not 'function) #'eql))) + (declare (type (or function null) key) + (type function test test-not)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) (setq result (cons elt result)))) - (dolist (elt list2) - (unless (with-set-keys (member (apply-key key elt) list1)) - (setq result (cons elt result)))) + (let ((test (if testp + (lambda (x y) (funcall test y x)) + test)) + (test-not (if notp + (lambda (x y) (funcall test-not y x)) + test-not))) + (dolist (elt list2) + (unless (with-set-keys (member (apply-key key elt) list1)) + (setq result (cons elt result))))) result)) ;;; The outer loop examines list1 while the inner loop examines list2. |