-;;; Like CMU CL, we use HEAPSORT. However, 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.
-(macrolet ((%index (x) `(truly-the index ,x))
- (%parent (i) `(ash ,i -1))
- (%left (i) `(%index (ash ,i 1)))
- (%right (i) `(%index (1+ (ash ,i 1))))
- (%heapify (i)
- `(do* ((i ,i)
- (left (%left i) (%left i)))
- ((> left current-heap-size))
- (declare (type index i left))
- (let* ((i-elt (%elt i))
- (i-key (funcall keyfun i-elt))
- (left-elt (%elt left))
- (left-key (funcall keyfun left-elt)))
- (multiple-value-bind (large large-elt large-key)
- (if (funcall predicate i-key left-key)
- (values left left-elt left-key)
- (values i i-elt i-key))
- (let ((right (%right i)))
- (multiple-value-bind (largest largest-elt)
- (if (> right current-heap-size)
- (values large large-elt)
- (let* ((right-elt (%elt right))
- (right-key (funcall keyfun right-elt)))
- (if (funcall predicate large-key right-key)
- (values right right-elt)
- (values large large-elt))))
- (cond ((= largest i)
- (return))
- (t
- (setf (%elt i) largest-elt
- (%elt largest) i-elt
- i largest)))))))))
- (%srt-vector (keyfun &optional (vtype 'vector))
- `(macrolet (;; 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.
- (current-heap-size (- end start))
- (keyfun ,keyfun))
- (declare (type (integer -1 #.(1- most-positive-fixnum))
- start-1))
- (declare (type index current-heap-size))
- (declare (type function keyfun))
- (/noshow "doing SRT-VECTOR" keyfun)
- (loop for i of-type index
- from (ash current-heap-size -1) downto 1 do
- (/noshow vector "about to %HEAPIFY" i)
- (%heapify i))
- (loop
- (/noshow current-heap-size vector)
- (when (< current-heap-size 2)
- (/noshow "returning")
- (return))
- (/noshow "setting" current-heap-size "element to" (%elt 1))
- (rotatef (%elt 1) (%elt current-heap-size))
- (decf current-heap-size)
- (%heapify 1))
- (/noshow "falling out of %SRT-VECTOR")))))
-
- (declaim (inline srt-vector))
- (defun srt-vector (vector start end predicate key)
- (declare (type vector vector))
- (declare (type index start end))
- (declare (type function predicate))
- (declare (type (or function null) key))
- (declare (optimize (speed 3) (safety 3) (debug 1) (space 1)))
- (if (typep vector 'simple-vector)
- ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
- ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
- (if (null key)
- ;; Special-casing the KEY=NIL case lets us avoid some
- ;; function calls.
- (%srt-vector #'identity simple-vector)
- (%srt-vector key simple-vector))
- ;; It's hard to imagine many important applications for
- ;; sorting vector types other than (VECTOR T), so we just lump
- ;; them all together in one slow dynamically typed mess.
- (locally
- (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
- (error "stub: suppressed to hide notes")
- #+nil (%srt-vector (or key #'identity))))))
-
-(declaim (maybe-inline sort))
-(defun sort (sequence predicate &key key)
- (let ((predicate-function (%coerce-callable-to-function predicate))
- (key-function (and key (%coerce-callable-to-function key))))
- (typecase sequence
- (list (sort-list sequence predicate-function key-function))
- (vector
- (with-array-data ((vector (the vector sequence))
- (start 0)
- (end (length sequence)))
- (srt-vector vector start end predicate-function key-function))
- (/noshow "back from SRT-VECTOR" sequence)
- sequence)
- (t
- (error 'simple-type-error
- :datum sequence
- :expected-type 'sequence
- :format-control "~S is not a sequence."
- :format-arguments (list sequence))))))
-
-(defun vector-push-extend (new-element
- vector
- &optional
- (extension nil extension-p))
- (declare (type vector vector))
- (let ((old-fill-pointer (fill-pointer vector)))
- (declare (type index old-fill-pointer))
- (when (= old-fill-pointer (%array-available-elements vector))
- (adjust-array vector (+ old-fill-pointer
- (if extension-p
- (the (integer 1 #.most-positive-fixnum)
- extension)
- (1+ old-fill-pointer)))))
- (setf (%array-fill-pointer vector)
- (1+ old-fill-pointer))
- ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
- ;; saves some time.
- (with-array-data ((v vector) (i old-fill-pointer) (end)
- :force-inline t)
- (declare (ignore end) (optimize (safety 0)))
- (if (simple-vector-p v) ; if common special case
- (setf (aref v i) new-element)
- (setf (aref v i) new-element)))
- old-fill-pointer))
-