0.7.11.3:

        Fixed bug in embedded calls of SORT (reported and investigated
        by Wolfgang Jenkner).

diff --git a/NEWS b/NEWS
index d7f2e71..3cb64d9 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1485,6 +1485,8 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10:
 
 changes in sbcl-0.7.12 relative to sbcl-0.7.11:
   * fixed bug 62: constraints were not propagated into a loop.
+  * fixed bug in embedded calls of SORT (reported and investigated by
+    Wolfgang Jenkner).
 
 planned incompatible changes in 0.7.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index d1337f3..d29d878 100644 (file)
--- a/src/code/sort.lisp
+++ b/src/code/sort.lisp
@@ -140,25 +140,28 @@
 ;;; list, elements of list-2 are guaranteed to come after equal elements
 ;;; of list-1.
 (defun merge-lists* (list-1 list-2 pred key)
-  (do* ((result *merge-lists-header*)
-       (P result))                  ; points to last cell of result
-       ((or (null list-1) (null list-2)) ; done when either list used up
-       (if (null list-1)              ; in which case, append the
-           (rplacd p list-2)      ;   other list
-           (rplacd p list-1))
-       (do ((drag p lead)
-            (lead (cdr p) (cdr lead)))
-           ((null lead)
-            (values (prog1 (cdr result) ; Return the result sans header
-                           (rplacd result nil)) ; (free memory, be careful)
-                    drag))))      ;   and return pointer to last element.
-    (cond ((apply-pred (car list-2) (car list-1) pred key)
-          (rplacd p list-2)       ; Append the lesser list to last cell of
-          (setq p (cdr p))         ;   result. Note: test must be done for
-          (pop list-2))               ;   LIST-2 < LIST-1 so merge will be
-         (T (rplacd p list-1)   ;   stable for LIST-1.
-            (setq p (cdr p))
-            (pop list-1)))))
+  (let* ((result *merge-lists-header*)
+         (merge-lists-trailer (cdr *merge-lists-header*)))
+    (unwind-protect
+         (do ((P result))             ; points to last cell of result
+             ((or (null list-1) (null list-2)) ; done when either list used up
+              (if (null list-1)        ; in which case, append the
+                  (rplacd p list-2)    ;   other list
+                  (rplacd p list-1))
+              (do ((drag p lead)
+                   (lead (cdr p) (cdr lead)))
+                  ((null lead)
+                   (values (cdr result) ; Return the result sans header
+                           drag)))) ; and return pointer to last element.
+           (cond ((apply-pred (car list-2) (car list-1) pred key)
+                  (rplacd p list-2) ; Append the lesser list to last cell of
+                  (setq p (cdr p)) ; result. Note: test must be done for
+                  (pop list-2))     ; LIST-2 < LIST-1 so merge will be
+                 (T (rplacd p list-1)   ; stable for LIST-1.
+                    (setq p (cdr p))
+                    (pop list-1))))
+      (setf (cdr result) merge-lists-trailer) ; (free memory, be careful)
+      )))
 
 ;;; stable sort of vectors
 

diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp
index 21b2a4f..cb1cfe0 100644 (file)
--- a/tests/seq.pure.lisp
+++ b/tests/seq.pure.lisp
@@ -119,3 +119,20 @@
 (assert (equal (remove 1 '(1 2 3 1) :count 1) '(2 3 1)))
 (assert (equal (remove 1 '(1 2 3 1) :count (* 2 most-positive-fixnum)) '(2 3)))
 (assert (equal (remove 1 '(1 2 3 1) :count (* -2 most-positive-fixnum)) '(1 2 3 1)))
+
+;;; bug reported by Wolfgang Jenkner on sbcl-devel 2003-01-04:
+;;; embedded calls of SORT do not work
+(assert (equal (sort (list 0 0 0) (lambda (x y) (sort (list 0 0 0) #'<) nil))
+               '(0 0 0)))
+(assert (equal (sort (list 0 0 0 0 0)
+                     (lambda (x y)
+                       (declare (ignore x y))
+                       (block compare
+                         (sort (make-list 11 :initial-element 1)
+                               (let ((counter 7))
+                                 (lambda (x y)
+                                   (declare (ignore x y))
+                                   (when (= (decf counter) 0)
+                                     (return-from compare nil))
+                                   t))))))
+               '(0 0 0 0 0)))

diff --git a/version.lisp-expr b/version.lisp-expr
index e7dabca..a9edd74 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.11.2"
+"0.7.11.3"