From: Alexey D. <ade...@us...> - 2003-01-04 14:42:46
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs1:/tmp/cvs-serv7738/src/code Modified Files: sort.lisp Log Message: 0.7.11.3: Fixed bug in embedded calls of SORT (reported and investigated by Wolfgang Jenkner). Index: sort.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/sort.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- sort.lisp 4 Dec 2002 15:23:02 -0000 1.14 +++ sort.lisp 4 Jan 2003 14:42:40 -0000 1.15 @@ -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 |