From: Alexey Dejneka <adejneka@comail.ru>
Date: Sat, 4 Jan 2003 14:42:39 +0000 (+0000)
Subject: 0.7.11.3:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=84d5caf8c4c709bb39ba98b07b84cab90c234bfd;p=sbcl.git

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
--- 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
--- 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
--- 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
--- 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"