1 ;;;; (See the comments at the head of the file compiler-extras.lisp.)
5 (declaim (optimize (speed 3) (space 1)))
7 (defun %with-array-data (array start end)
8 (%with-array-data-macro array start end :fail-inline? t))
10 ;;; Like CMU CL, we use HEAPSORT. However, instead of trying to
11 ;;; generalize the CMU CL code to allow START and END values, this
12 ;;; code has been written from scratch following Chapter 7 of
13 ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
14 (macrolet ((%index (x) `(truly-the index ,x))
15 (%parent (i) `(ash ,i -1))
16 (%left (i) `(%index (ash ,i 1)))
17 (%right (i) `(%index (1+ (ash ,i 1))))
20 (left (%left i) (%left i)))
21 ((> left current-heap-size))
22 (declare (type index i left))
23 (let* ((i-elt (%elt i))
24 (i-key (funcall keyfun i-elt))
25 (left-elt (%elt left))
26 (left-key (funcall keyfun left-elt)))
27 (multiple-value-bind (large large-elt large-key)
28 (if (funcall predicate i-key left-key)
29 (values left left-elt left-key)
30 (values i i-elt i-key))
31 (let ((right (%right i)))
32 (multiple-value-bind (largest largest-elt)
33 (if (> right current-heap-size)
34 (values large large-elt)
35 (let* ((right-elt (%elt right))
36 (right-key (funcall keyfun right-elt)))
37 (if (funcall predicate large-key right-key)
38 (values right right-elt)
39 (values large large-elt))))
43 (setf (%elt i) largest-elt
46 (%srt-vector (keyfun &optional (vtype 'vector))
47 `(macrolet (;; In SBCL ca. 0.6.10, I had trouble getting
48 ;; type inference to propagate all the way
49 ;; through this tangled mess of inlining. The
50 ;; TRULY-THE here works around that. -- WHN
52 `(aref (truly-the ,',vtype vector)
53 (%index (+ (%index ,i) start-1)))))
54 (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
55 (current-heap-size (- end start))
57 (declare (type (integer -1 #.(1- most-positive-fixnum))
59 (declare (type index current-heap-size))
60 (declare (type function keyfun))
61 (/noshow "doing SRT-VECTOR" keyfun)
62 (loop for i of-type index
63 from (ash current-heap-size -1) downto 1 do
64 (/noshow vector "about to %HEAPIFY" i)
67 (/noshow current-heap-size vector)
68 (when (< current-heap-size 2)
71 (/noshow "setting" current-heap-size "element to" (%elt 1))
72 (rotatef (%elt 1) (%elt current-heap-size))
73 (decf current-heap-size)
75 (/noshow "falling out of %SRT-VECTOR")))))
77 (declaim (inline srt-vector))
78 (defun srt-vector (vector start end predicate key)
79 (declare (type vector vector))
80 (declare (type index start end))
81 (declare (type function predicate))
82 (declare (type (or function null) key))
83 (declare (optimize (speed 3) (safety 3) (debug 1) (space 1)))
84 (if (typep vector 'simple-vector)
85 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
86 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
88 ;; Special-casing the KEY=NIL case lets us avoid some
90 (%srt-vector #'identity simple-vector)
91 (%srt-vector key simple-vector))
92 ;; It's hard to imagine many important applications for
93 ;; sorting vector types other than (VECTOR T), so we just lump
94 ;; them all together in one slow dynamically typed mess.
96 (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
97 (error "stub: suppressed to hide notes")
98 #+nil (%srt-vector (or key #'identity))))))
100 (declaim (maybe-inline sort))
101 (defun sort (sequence predicate &key key)
102 (let ((predicate-function (%coerce-callable-to-function predicate))
103 (key-function (and key (%coerce-callable-to-function key))))
105 (list (sort-list sequence predicate-function key-function))
107 (with-array-data ((vector (the vector sequence))
109 (end (length sequence)))
110 (srt-vector vector start end predicate-function key-function))
111 (/noshow "back from SRT-VECTOR" sequence)
114 (error 'simple-type-error
116 :expected-type 'sequence
117 :format-control "~S is not a sequence."
118 :format-arguments (list sequence))))))
120 (defun vector-push-extend (new-element
123 (extension nil extension-p))
124 (declare (type vector vector))
125 (let ((old-fill-pointer (fill-pointer vector)))
126 (declare (type index old-fill-pointer))
127 (when (= old-fill-pointer (%array-available-elements vector))
128 (adjust-array vector (+ old-fill-pointer
130 (the (integer 1 #.most-positive-fixnum)
132 (1+ old-fill-pointer)))))
133 (setf (%array-fill-pointer vector)
134 (1+ old-fill-pointer))
135 ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
137 (with-array-data ((v vector) (i old-fill-pointer) (end)
139 (declare (ignore end) (optimize (safety 0)))
140 (if (simple-vector-p v) ; if common special case
141 (setf (aref v i) new-element)
142 (setf (aref v i) new-element)))
145 ;;; FIXME: should DEFUN REPLACE in terms of same expansion as
149 (cond ((and (typep seq1 'simple-vector)
150 (typep seq2 'simple-vector))
151 (%replace-vector-vector ..))
152 ((and (typep seq1 'simple-string)
153 (typep seq2 'simple-string))
154 (%replace-vector-vector ..))
158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159 ;;;; POSITION/FIND stuff
162 (eval-when (:compile-toplevel :load-toplevel :execute)
163 ;; FIXME: Report seq.impure.lisp test failures to cmucl-imp@cons.org.
164 ;; FIXME: Add BUGS entry for the way that inline expansions offunctions
165 ;; like FIND cause compiler warnings when the system can't prove that
166 ;; NIL is never returned; and give (NEED (FIND ..)) workaround.
167 (error "need to fix FIXMEs"))
169 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
170 ;;; POSITION-IF, etc.
171 (declaim (inline effective-find-position-test effective-find-position-key))
172 (defun effective-find-position-test (test test-not)
173 (cond ((and test test-not)
174 (error "can't specify both :TEST and :TEST-NOT"))
175 (test (%coerce-callable-to-function test))
177 ;; (Without DYNAMIC-EXTENT, this is potentially horribly
178 ;; inefficient, but since the TEST-NOT option is deprecated
179 ;; anyway, we don't care.)
180 (complement (%coerce-callable-to-function test-not)))
182 (defun effective-find-position-key (key)
184 (%coerce-callable-to-function key)
187 ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
188 (macrolet (;; shared logic for defining %FIND-POSITION and
189 ;; %FIND-POSITION-IF in terms of various inlineable cases
190 ;; of the expression defined in FROB and VECTOR*-FROB
192 `(etypecase sequence-arg
193 (list (frob sequence-arg from-end))
195 (with-array-data ((sequence sequence-arg :offset-var offset)
197 (end (or end (length sequence-arg))))
198 (multiple-value-bind (f p)
199 (macrolet ((frob2 () '(if from-end
201 (frob sequence nil))))
203 (simple-vector (frob2))
204 (simple-string (frob2))
205 (t (vector*-frob sequence))))
206 (declare (type (or index null) p))
207 (values f (and p (the index (+ p offset))))))))))
208 (defun %find-position (item sequence-arg from-end start end key test)
209 (macrolet ((frob (sequence from-end)
210 `(%find-position item ,sequence
211 ,from-end start end key test))
212 (vector*-frob (sequence)
213 `(%find-position-vector-macro item ,sequence
214 from-end start end key test)))
216 (defun %find-position-if (predicate sequence-arg from-end start end key)
217 (macrolet ((frob (sequence from-end)
218 `(%find-position-if predicate ,sequence
219 ,from-end start end key))
220 (vector*-frob (sequence)
221 `(%find-position-if-vector-macro predicate ,sequence
222 from-end start end key)))
225 ;;; the user interface to FIND and POSITION: Get all our ducks in a row,
226 ;;; then call %FIND-POSITION
227 (declaim (inline find position))
228 (macrolet ((def-find-position (fun-name values-index)
229 `(defun ,fun-name (item
245 (effective-find-position-key key)
246 (effective-find-position-test test
248 (def-find-position find 0)
249 (def-find-position position 1))
251 ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
252 ;;; to the interface to FIND and POSITION
253 (declaim (inline find-if position-if))
254 (macrolet ((def-find-position-if (fun-name values-index)
255 `(defun ,fun-name (predicate sequence
256 &key from-end (start 0) end key)
259 (%find-position-if (%coerce-callable-to-function predicate)
264 (effective-find-position-key key))))))
266 (def-find-position-if find-if 0)
267 (def-find-position-if position-if 1))
269 ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
270 (macrolet ((def-find-position-if-not (fun-name values-index)
271 `(defun ,fun-name (predicate sequence
272 &key from-end (start 0) end key)
275 (%find-position-if (complement (%coerce-callable-to-function
281 (effective-find-position-key key))))))
282 (def-find-position-if-not find-if-not 0)
283 (def-find-position-if-not position-if-not 1))
284 ;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.