From ce8abda743c65dc1031815a26f9f2707a1be3dba Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Fri, 27 Nov 1998 22:17:04 +0000 Subject: [PATCH] Rework the sort functions so that they are reentrant; remove the variable *merge-lists-header* which was destructively modified by merge-lists*; and remove the variable *merge-sort-temp-vector* allocating a fresh vector for each vector stable-sort. --- code/sort.lisp | 126 +++++++++++++++++++++++-------------------------- 1 file changed, 60 insertions(+), 66 deletions(-) diff --git a/code/sort.lisp b/code/sort.lisp index db9298158..1b40adc04 100644 --- a/code/sort.lisp +++ b/code/sort.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sort.lisp,v 1.6 1998/07/16 13:30:51 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sort.lisp,v 1.7 1998/11/27 22:17:04 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -152,6 +152,45 @@ ;;; Stable Sorting Lists +;;; APPLY-PRED saves us a function call sometimes. +(eval-when (compile eval) + (defmacro apply-pred (one two pred key) + `(if ,key + (funcall ,pred (funcall ,key ,one) + (funcall ,key ,two)) + (funcall ,pred ,one ,two))) +) ; eval-when + + +;;; MERGE-LISTS* originally written by Jim Large. +;;; modified to return a pointer to the end of the result +;;; and to not cons header each time its called. +;;; It destructively merges list-1 with list-2. In the resulting +;;; list, elements of list-2 are guaranteed to come after equal elements +;;; of list-1. +(defun merge-lists* (list-1 list-2 pred key + &optional (merge-lists-header (list :header))) + (do* ((result merge-lists-header) + (P result)) ; P 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 bo 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))))) + + ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over ;;; the list grabbing one element at a time and merging it with the next one ;;; form pairs of sorted elements. Then n is doubled, and elements are taken @@ -167,7 +206,8 @@ unsorted ; unsorted is the remaining list to be ; broken into n size lists and merged list-1 ; list-1 is one length n list to be merged - last) ; last points to the last visited cell + last ; last points to the last visited cell + (merge-lists-header (list :header))) (declare (fixnum n)) (loop ;; start collecting runs of n at the first element @@ -191,7 +231,8 @@ ;; the second run goes off the end of the list (t (setf unsorted nil))) (multiple-value-bind (merged-head merged-last) - (merge-lists* list-1 list-2 pred key) + (merge-lists* list-1 list-2 pred key + merge-lists-header) (setf (cdr last) merged-head) (setf last merged-last)) (if (null unsorted) (return))) @@ -206,45 +247,6 @@ (return list-1)))))) -;;; APPLY-PRED saves us a function call sometimes. -(eval-when (compile eval) - (defmacro apply-pred (one two pred key) - `(if ,key - (funcall ,pred (funcall ,key ,one) - (funcall ,key ,two)) - (funcall ,pred ,one ,two))) -) ; eval-when - -(defvar *merge-lists-header* (list :header)) - -;;; MERGE-LISTS* originally written by Jim Large. -;;; modified to return a pointer to the end of the result -;;; and to not cons header each time its called. -;;; It destructively merges list-1 with list-2. In the resulting -;;; 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)) ; P 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 bo 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))))) - - ;;; Stable Sort Vectors @@ -304,19 +306,17 @@ (let ((vector-len (gensym)) (n (gensym)) (direction (gensym)) (unsorted (gensym)) (start-1 (gensym)) (end-1 (gensym)) - (end-2 (gensym)) (temp-len (gensym)) - (i (gensym))) - `(let ((,vector-len (length (the vector ,vector))) - (,n 1) ; bottom-up size of contiguous runs to be merged - (,direction t) ; t vector --> temp nil temp --> vector - (,temp-len (length (the simple-vector *merge-sort-temp-vector*))) - (,unsorted 0) ; unsorted..vector-len are the elements that need - ; to be merged for a given n - (,start-1 0)) ; one n-len subsequence to be merged with the next - (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)) - (if (> ,vector-len ,temp-len) - (setf *merge-sort-temp-vector* - (make-array (max ,vector-len (+ ,temp-len ,temp-len))))) + (end-2 (gensym)) (i (gensym)) + (temp-vector (gensym))) + `(let* ((,vector-len (length (the vector ,vector))) + (,n 1) ; bottom-up size of contiguous runs to be merged + (,direction t) ; t vector --> temp nil temp --> vector + (,temp-vector (make-array ,vector-len)) + (,unsorted 0) ; unsorted..vector-len are the elements that need + ; to be merged for a given n + (,start-1 0)) ; one n-len subsequence to be merged with the next + (declare (fixnum ,vector-len ,n ,unsorted ,start-1) + (type simple-vector ,temp-vector)) (loop ;; for each n, we start taking n-runs from the start of the vector (setf ,unsorted 0) @@ -332,10 +332,10 @@ (setf ,unsorted ,end-2) (if ,direction (stable-sort-merge-vectors* - ,vector *merge-sort-temp-vector* + ,vector ,temp-vector ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) (stable-sort-merge-vectors* - *merge-sort-temp-vector* ,vector + ,temp-vector ,vector ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) (if (= ,unsorted ,vector-len) (return)))) ;; if there is only one run, copy those elements to the end @@ -343,13 +343,13 @@ (do ((,i ,start-1 (1+ ,i))) ((= ,i ,vector-len)) (declare (fixnum ,i)) - (setf (svref *merge-sort-temp-vector* ,i) + (setf (svref ,temp-vector ,i) (,vector-ref ,vector ,i))) (do ((,i ,start-1 (1+ ,i))) ((= ,i ,vector-len)) (declare (fixnum ,i)) (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) + (svref ,temp-vector ,i)))) (return))))) ;; If the inner loop only executed once, then there were only enough ;; elements for two subsequences given n, so all the elements have @@ -360,7 +360,7 @@ ;; to the given vector. (dotimes (,i ,vector-len) (setf (,vector-ref ,vector ,i) - (svref *merge-sort-temp-vector* ,i)))) + (svref ,temp-vector ,i)))) (return ,vector)) (setf ,n (ash ,n 1)) ; (* 2 n) (setf ,direction (not ,direction)))))) @@ -368,12 +368,6 @@ ) ; eval-when -;;; Temporary vector for stable sorting vectors. -(defvar *merge-sort-temp-vector* - (make-array 50)) - -(proclaim '(simple-vector *merge-sort-temp-vector*)) - (defun stable-sort-simple-vector (vector pred key) (declare (simple-vector vector)) (vector-merge-sort vector pred key svref)) -- GitLab