From: William Harold Newman Date: Thu, 5 Feb 2004 02:13:17 +0000 (+0000) Subject: 0.8.7.45: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=sidebyside;h=ffdebb412afde6c9cd9f433c8537519135d648c2;p=sbcl.git 0.8.7.45: merged patch from Robert E. Brown to OAOOify and tidy the coercion of SORT-related function designators to functions --- diff --git a/src/code/sort.lisp b/src/code/sort.lisp index f30c67d..636c417 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -11,13 +11,8 @@ (in-package "SB!IMPL") -;;; Like CMU CL, we use HEAPSORT. However, other than that, this code -;;; isn't really related to the CMU CL code, since instead of trying -;;; to generalize the CMU CL code to allow START and END values, this -;;; code has been written from scratch following Chapter 7 of -;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. -(defun sort-vector (vector start end predicate key) - (sort-vector vector start end predicate key)) +(defun sort-vector (vector start end predicate-fun key-fun-or-nil) + (sort-vector vector start end predicate-fun key-fun-or-nil)) ;;; This is MAYBE-INLINE because it's not too hard to have an ;;; application where sorting is a major bottleneck, and inlining it @@ -28,15 +23,18 @@ #!+sb-doc "Destructively sort SEQUENCE. PREDICATE should return non-NIL if ARG1 is to precede ARG2." - (let ((predicate-function (%coerce-callable-to-fun predicate)) - (key-function (and key (%coerce-callable-to-fun key)))) + (let ((predicate-fun (%coerce-callable-to-fun predicate))) (typecase sequence - (list (stable-sort-list sequence predicate-function key-function)) + (list + (stable-sort-list sequence + predicate-fun + (if key (%coerce-callable-to-fun key) #'identity))) (vector - (with-array-data ((vector (the vector sequence)) - (start 0) - (end (length sequence))) - (sort-vector vector start end predicate-function key-function)) + (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key)))) + (with-array-data ((vector (the vector sequence)) + (start 0) + (end (length sequence))) + (sort-vector vector start end predicate-fun key-fun-or-nil))) sequence) (t (error 'simple-type-error @@ -51,20 +49,27 @@ #!+sb-doc "Destructively sort SEQUENCE. PREDICATE should return non-NIL if ARG1 is to precede ARG2." - (typecase sequence - (simple-vector - (stable-sort-simple-vector sequence predicate key)) - (list - (stable-sort-list sequence predicate key)) - (vector - (stable-sort-vector sequence predicate key)) - (t - (error 'simple-type-error - :datum sequence - :expected-type 'sequence - :format-control "~S is not a sequence." - :format-arguments (list sequence))))) - + (let ((predicate-fun (%coerce-callable-to-fun predicate))) + (typecase sequence + (simple-vector + (stable-sort-simple-vector sequence + predicate-fun + (and key (%coerce-callable-to-fun key)))) + (list + (stable-sort-list sequence + predicate-fun + (if key (%coerce-callable-to-fun key) #'identity))) + (vector + (stable-sort-vector sequence + predicate-fun + (and key (%coerce-callable-to-fun key)))) + (t + (error 'simple-type-error + :datum sequence + :expected-type 'sequence + :format-control "~S is not a sequence." + :format-arguments (list sequence)))))) + ;;; APPLY-KEYED-PRED saves us a function call sometimes. (eval-when (:compile-toplevel :execute) (sb!xc:defmacro apply-keyed-pred (one two pred key) @@ -133,18 +138,15 @@ ;;; that is, there are only two runs that can be merged, the first run ;;; starting at the beginning of the list, and the second being the ;;; remaining elements. -(defun stable-sort-list (list pred key) +(defun stable-sort-list (list pred-fun key-fun) (let ((head (cons :header list)) ; head holds on to everything (n 1) ; bottom-up size of lists to be merged 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 - (pred-fun (%coerce-callable-to-fun pred)) - (key-fun (if key - (%coerce-callable-to-fun key) - #'identity))) - (declare (fixnum n)) + last) ; last points to the last visited cell + (declare (type function pred-fun key-fun) + (type fixnum n)) (loop ;; Start collecting runs of N at the first element. (setf unsorted (cdr head)) @@ -309,10 +311,14 @@ (declaim (simple-vector *merge-sort-temp-vector*)) (defun stable-sort-simple-vector (vector pred key) - (declare (simple-vector vector)) + (declare (type simple-vector vector) + (type function pred) + (type (or null function) key)) (vector-merge-sort vector pred key svref)) (defun stable-sort-vector (vector pred key) + (declare (type function pred) + (type (or null function) key)) (vector-merge-sort vector pred key aref)) ;;;; merging diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 6ba54f8..f4b0045 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3583,6 +3583,11 @@ (t *universal-type*))))) +;;; Like CMU CL, we use HEAPSORT. However, other than that, this code +;;; isn't really related to the CMU CL code, since instead of trying +;;; to generalize the CMU CL code to allow START and END values, this +;;; code has been written from scratch following Chapter 7 of +;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. (define-source-transform sb!impl::sort-vector (vector start end predicate key) `(macrolet ((%index (x) `(truly-the index ,x)) (%parent (i) `(ash ,i -1)) @@ -3617,15 +3622,16 @@ (%elt largest) i-elt i largest))))))))) (%sort-vector (keyfun &optional (vtype 'vector)) - `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting - ;; type inference to propagate all the way - ;; through this tangled mess of - ;; inlining. The TRULY-THE here works - ;; around that. -- WHN + `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had + ;; trouble getting type inference to + ;; propagate all the way through this + ;; tangled mess of inlining. The TRULY-THE + ;; here works around that. -- WHN (%elt (i) `(aref (truly-the ,',vtype ,',',vector) (%index (+ (%index ,i) start-1))))) - (let ((start-1 (1- ,',start)) ; Heaps prefer 1-based addressing. + (let (;; Heaps prefer 1-based addressing. + (start-1 (1- ,',start)) (current-heap-size (- ,',end ,',start)) (keyfun ,keyfun)) (declare (type (integer -1 #.(1- most-positive-fixnum)) diff --git a/version.lisp-expr b/version.lisp-expr index 627fd99..6ff65c0 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.7.44" +"0.8.7.45"