1.0.21.19: Eagerly find a stream's external-format when a coding-error occurs.
[sbcl.git] / src / code / sort.lisp
1 ;;;; SORT and friends
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13
14 (defun sort-vector (vector start end predicate-fun key-fun-or-nil)
15   (sort-vector vector start end predicate-fun key-fun-or-nil))
16
17 ;;; This is MAYBE-INLINE because it's not too hard to have an
18 ;;; application where sorting is a major bottleneck, and inlining it
19 ;;; allows the compiler to make enough optimizations that it might be
20 ;;; worth the (large) cost in space.
21 (declaim (maybe-inline sort))
22 (defun sort (sequence predicate &rest args &key key)
23   #!+sb-doc
24   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
25    ARG1 is to precede ARG2."
26   (declare (truly-dynamic-extent args))
27   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
28     (seq-dispatch sequence
29       (stable-sort-list sequence
30                         predicate-fun
31                         (if key (%coerce-callable-to-fun key) #'identity))
32       (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
33         (with-array-data ((vector (the vector sequence))
34                           (start)
35                           (end)
36                           :check-fill-pointer t)
37           (sort-vector vector start end predicate-fun key-fun-or-nil))
38         sequence)
39       (apply #'sb!sequence:sort sequence predicate args))))
40 \f
41 ;;;; stable sorting
42 (defun stable-sort (sequence predicate &rest args &key key)
43   #!+sb-doc
44   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
45    ARG1 is to precede ARG2."
46   (declare (truly-dynamic-extent args))
47   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
48     (seq-dispatch sequence
49       (stable-sort-list sequence
50                         predicate-fun
51                         (if key (%coerce-callable-to-fun key) #'identity))
52       (if (typep sequence 'simple-vector)
53           (stable-sort-simple-vector sequence
54                                      predicate-fun
55                                      (and key (%coerce-callable-to-fun key)))
56           (stable-sort-vector sequence
57                               predicate-fun
58                               (and key (%coerce-callable-to-fun key))))
59       (apply #'sb!sequence:stable-sort sequence predicate args))))
60 \f
61 ;;; FUNCALL-USING-KEY saves us a function call sometimes.
62 (eval-when (:compile-toplevel :execute)
63   (sb!xc:defmacro funcall2-using-key (pred key one two)
64     `(if ,key
65          (funcall ,pred (funcall ,key ,one)
66                   (funcall ,key  ,two))
67          (funcall ,pred ,one ,two)))
68 ) ; EVAL-WHEN
69 \f
70 ;;;; stable sort of lists
71
72 (defun last-cons-of (list)
73   (loop (let ((rest (rest list)))
74           (if rest
75               (setf list rest)
76               (return list)))))
77
78 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
79 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
80 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
81 ;;; come before equal elements of LIST-2.
82 ;;;
83 ;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
84 ;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
85 ;;; the last cons in the list which NRECONC calls TAIL).
86 (defun merge-lists* (list-1 list-2 pred-fun key-fun)
87   (declare (type list list-1 list-2))
88   (declare (type function pred-fun key-fun))
89   (cond ((null list-1) (values list-2 (last-cons-of list-2)))
90         ((null list-2) (values list-1 (last-cons-of list-1)))
91         (t (let* ((reversed-result-so-far nil)
92                   (key-1 (funcall key-fun (car list-1)))
93                   (key-2 (funcall key-fun (car list-2))))
94              (loop
95               (macrolet ((frob (list-i key-i other-list)
96                            `(progn
97                               ;; basically
98                               ;;   (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
99                               ;; except doing some fancy footwork to
100                               ;; reuse the cons cell:
101                               (psetf (cdr ,list-i) reversed-result-so-far
102                                      reversed-result-so-far ,list-i
103                                      ,list-i (cdr ,list-i))
104                               ;; Now maybe we're done.
105                               (if (endp ,list-i)
106                                   (return (values (nreconc
107                                                    reversed-result-so-far
108                                                    ,other-list)
109                                                   (last-cons-of
110                                                    ,other-list)))
111                                   (setf ,key-i
112                                         (funcall key-fun (car ,list-i)))))))
113                 ;; Note that by making KEY-2 the first arg to
114                 ;; PRED-FUN, we arrange that if PRED-FUN is a function
115                 ;; in the #'< style, the outcome is stably sorted.
116                 (if (funcall pred-fun key-2 key-1)
117                     (frob list-2 key-2 list-1)
118                     (frob list-1 key-1 list-2))))))))
119
120 ;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
121 ;;; over the list grabbing one element at a time and merging it with
122 ;;; the next one to form pairs of sorted elements. Then N is doubled,
123 ;;; and elements are taken in runs of two, merging one run with the
124 ;;; next to form quadruples of sorted elements. This continues until N
125 ;;; is large enough that the inner loop only runs for one iteration;
126 ;;; that is, there are only two runs that can be merged, the first run
127 ;;; starting at the beginning of the list, and the second being the
128 ;;; remaining elements.
129 (defun stable-sort-list (list pred-fun key-fun)
130   (let ((head (cons :header list))  ; head holds on to everything
131         (n 1)                       ; bottom-up size of lists to be merged
132         unsorted                    ; unsorted is the remaining list to be
133                                     ;   broken into n size lists and merged
134         list-1                      ; list-1 is one length n list to be merged
135         last)                       ; last points to the last visited cell
136     (declare (type function pred-fun key-fun)
137              (type fixnum n))
138     (loop
139      ;; Start collecting runs of N at the first element.
140      (setf unsorted (cdr head))
141      ;; Tack on the first merge of two N-runs to the head holder.
142      (setf last head)
143      (let ((n-1 (1- n)))
144        (declare (fixnum n-1))
145        (loop
146         (setf list-1 unsorted)
147         (let ((temp (nthcdr n-1 list-1))
148               list-2)
149           (cond (temp
150                  ;; There are enough elements for a second run.
151                  (setf list-2 (cdr temp))
152                  (setf (cdr temp) nil)
153                  (setf temp (nthcdr n-1 list-2))
154                  (cond (temp
155                         (setf unsorted (cdr temp))
156                         (setf (cdr temp) nil))
157                        ;; The second run goes off the end of the list.
158                        (t (setf unsorted nil)))
159                  (multiple-value-bind (merged-head merged-last)
160                      (merge-lists* list-1 list-2 pred-fun key-fun)
161                    (setf (cdr last) merged-head
162                          last merged-last))
163                  (if (null unsorted) (return)))
164                 ;; If there is only one run, then tack it on to the end.
165                 (t (setf (cdr last) list-1)
166                    (return)))))
167        (setf n (ash n 1)) ; (+ n n)
168        ;; If the inner loop only executed once, then there were only
169        ;; enough elements for two runs given n, so all the elements
170        ;; have been merged into one list. This may waste one outer
171        ;; iteration to realize.
172        (if (eq list-1 (cdr head))
173            (return list-1))))))
174 \f
175 ;;;; stable sort of vectors
176
177 ;;; Stable sorting vectors is done with the same algorithm used for
178 ;;; lists, using a temporary vector to merge back and forth between it
179 ;;; and the given vector to sort.
180
181 (eval-when (:compile-toplevel :execute)
182
183 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
184 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
185 ;;;    end-1 (inclusive) ... end-2 (exclusive),
186 ;;; and merges them into a target vector starting at index start-1.
187
188 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
189                                                      pred key source-ref
190                                                      target-ref)
191   (let ((i (gensym))
192         (j (gensym))
193         (target-i (gensym)))
194     `(let ((,i ,start-1)
195            (,j ,end-1) ; start-2
196            (,target-i ,start-1))
197        (declare (fixnum ,i ,j ,target-i))
198        (loop
199         (cond ((= ,i ,end-1)
200                (loop (if (= ,j ,end-2) (return))
201                      (setf (,target-ref ,target ,target-i)
202                            (,source-ref ,source ,j))
203                      (incf ,target-i)
204                      (incf ,j))
205                (return))
206               ((= ,j ,end-2)
207                (loop (if (= ,i ,end-1) (return))
208                      (setf (,target-ref ,target ,target-i)
209                            (,source-ref ,source ,i))
210                      (incf ,target-i)
211                      (incf ,i))
212                (return))
213               ((funcall2-using-key ,pred ,key
214                                    (,source-ref ,source ,j)
215                                    (,source-ref ,source ,i))
216                (setf (,target-ref ,target ,target-i)
217                      (,source-ref ,source ,j))
218                (incf ,j))
219               (t (setf (,target-ref ,target ,target-i)
220                        (,source-ref ,source ,i))
221                  (incf ,i)))
222         (incf ,target-i)))))
223
224 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
225 ;;; but it uses a temporary vector. DIRECTION determines whether we
226 ;;; are merging into the temporary (T) or back into the given vector
227 ;;; (NIL).
228 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
229   (with-unique-names
230       (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len i)
231     `(let* ((,vector-len (length (the vector ,vector)))
232             (,n 1)        ; bottom-up size of contiguous runs to be merged
233             (,direction t) ; t vector --> temp    nil temp --> vector
234             (,temp *merge-sort-temp-vector*)
235             (,temp-len (length ,temp))
236             (,unsorted 0)  ; unsorted..vector-len are the elements that need
237                            ; to be merged for a given n
238             (,start-1 0))  ; one n-len subsequence to be merged with the next
239        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)
240                 (simple-vector ,temp))
241        (when (> ,vector-len ,temp-len)
242          (setf ,temp (make-array (max ,vector-len
243                                       (min (truncate array-dimension-limit 2)
244                                            (logand most-positive-fixnum (+ ,temp-len ,temp-len)))))
245                *merge-sort-temp-vector* ,temp))
246        ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also
247        ;; interrupt safe: we bind before we put any data of our own in
248        ;; the temp vector.
249        (let ((*merge-sort-temp-vector* (vector)))
250          (loop
251             ;; for each n, we start taking n-runs from the start of the vector
252             (setf ,unsorted 0)
253             (loop
254                (setf ,start-1 ,unsorted)
255                (let ((,end-1 (+ ,start-1 ,n)))
256                  (declare (fixnum ,end-1))
257                  (cond ((< ,end-1 ,vector-len)
258                         ;; there are enough elements for a second run
259                         (let ((,end-2 (+ ,end-1 ,n)))
260                           (declare (fixnum ,end-2))
261                           (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
262                           (setf ,unsorted ,end-2)
263                           (if ,direction
264                               (stable-sort-merge-vectors*
265                                ,vector ,temp
266                                ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
267                               (stable-sort-merge-vectors*
268                                ,temp ,vector
269                                ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
270                           (if (= ,unsorted ,vector-len) (return))))
271                        ;; if there is only one run, copy those elements to the end
272                        (t (if ,direction
273                               (do ((,i ,start-1 (1+ ,i)))
274                                   ((= ,i ,vector-len))
275                                 (declare (fixnum ,i))
276                                (setf (svref ,temp ,i)
277                                      (,vector-ref ,vector ,i)))
278                              (do ((,i ,start-1 (1+ ,i)))
279                                  ((= ,i ,vector-len))
280                                (declare (fixnum ,i))
281                                (setf (,vector-ref ,vector ,i)
282                                      (svref ,temp ,i))))
283                          (return)))))
284            ;; If the inner loop only executed once, then there were only enough
285            ;; elements for two subsequences given n, so all the elements have
286            ;; been merged into one list. Start-1 will have remained 0 upon exit.
287            (when (zerop ,start-1)
288              (if ,direction
289                  ;; if we just merged into the temporary, copy it all back
290                  ;; to the given vector.
291                  (dotimes (,i ,vector-len)
292                    (setf (,vector-ref ,vector ,i)
293                          (svref ,temp ,i))))
294              (return ,vector))
295            (setf ,n (ash ,n 1))         ; (* 2 n)
296            (setf ,direction (not ,direction)))))))
297
298 ) ; EVAL-when
299
300 (defun stable-sort-simple-vector (vector pred key)
301   (declare (type simple-vector vector)
302            (type function pred)
303            (type (or null function) key))
304   (vector-merge-sort vector pred key svref))
305
306 (defun stable-sort-vector (vector pred key)
307   (declare (type function pred)
308            (type (or null function) key))
309   (vector-merge-sort vector pred key aref))
310 \f
311 ;;;; merging
312
313 (eval-when (:compile-toplevel :execute)
314
315 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
316 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
317 ;;; are chosen only if they are strictly less than elements of
318 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
319 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
320                                result-vector pred key access)
321   (let ((result-i (gensym))
322         (i (gensym))
323         (j (gensym)))
324     `(let* ((,result-i 0)
325             (,i 0)
326             (,j 0))
327        (declare (fixnum ,result-i ,i ,j))
328        (loop
329         (cond ((= ,i ,length-1)
330                (loop (if (= ,j ,length-2) (return))
331                      (setf (,access ,result-vector ,result-i)
332                            (,access ,vector-2 ,j))
333                      (incf ,result-i)
334                      (incf ,j))
335                (return ,result-vector))
336               ((= ,j ,length-2)
337                (loop (if (= ,i ,length-1) (return))
338                      (setf (,access ,result-vector ,result-i)
339                            (,access ,vector-1 ,i))
340                      (incf ,result-i)
341                      (incf ,i))
342                (return ,result-vector))
343               ((funcall2-using-key ,pred ,key
344                                    (,access ,vector-2 ,j) (,access ,vector-1 ,i))
345                (setf (,access ,result-vector ,result-i)
346                      (,access ,vector-2 ,j))
347                (incf ,j))
348               (t (setf (,access ,result-vector ,result-i)
349                        (,access ,vector-1 ,i))
350                  (incf ,i)))
351         (incf ,result-i)))))
352
353 ) ; EVAL-WHEN
354
355 (defun merge (result-type sequence1 sequence2 predicate &key key)
356   #!+sb-doc
357   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
358    sequence of type RESULT-TYPE using PREDICATE to order the elements."
359   ;; FIXME: This implementation is remarkably inefficient in various
360   ;; ways. In decreasing order of estimated user astonishment, I note:
361   ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
362   ;; to lists before doing MERGE-LISTS*; and walking input lists
363   ;; (because of the call to MERGE-LISTS*, which walks the list to
364   ;; find the last element for its second return value) even in cases
365   ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
366   ;; can be largely ignored. -- WHN 2003-01-05
367   (let ((type (specifier-type result-type)))
368     (cond
369       ((csubtypep type (specifier-type 'list))
370        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
371        ;; benefits from the error checking there. Short of
372        ;; reimplementing everything, we can't do the same for the LIST
373        ;; case, so do relevant length checking here:
374        (let ((s1 (coerce sequence1 'list))
375              (s2 (coerce sequence2 'list))
376              (pred-fun (%coerce-callable-to-fun predicate))
377              (key-fun (if key
378                           (%coerce-callable-to-fun key)
379                           #'identity)))
380          (when (type= type (specifier-type 'list))
381            (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun))))
382          (when (eq type *empty-type*)
383            (bad-sequence-type-error nil))
384          (when (type= type (specifier-type 'null))
385            (if (and (null s1) (null s2))
386                (return-from merge 'nil)
387                ;; FIXME: This will break on circular lists (as,
388                ;; indeed, will the whole MERGE function).
389                (sequence-type-length-mismatch-error type
390                                                     (+ (length s1)
391                                                        (length s2)))))
392          (if (cons-type-p type)
393              (multiple-value-bind (min exactp)
394                  (sb!kernel::cons-type-length-info type)
395                (let ((length (+ (length s1) (length s2))))
396                  (if exactp
397                      (unless (= length min)
398                        (sequence-type-length-mismatch-error type length))
399                      (unless (>= length min)
400                        (sequence-type-length-mismatch-error type length)))
401                  (values (merge-lists* s1 s2 pred-fun key-fun))))
402              (sequence-type-too-hairy result-type))))
403       ((csubtypep type (specifier-type 'vector))
404        (let* ((vector-1 (coerce sequence1 'vector))
405               (vector-2 (coerce sequence2 'vector))
406               (length-1 (length vector-1))
407               (length-2 (length vector-2))
408               (result (make-sequence result-type (+ length-1 length-2))))
409          (declare (vector vector-1 vector-2)
410                   (fixnum length-1 length-2))
411          (if (and (simple-vector-p result)
412                   (simple-vector-p vector-1)
413                   (simple-vector-p vector-2))
414              (merge-vectors vector-1 length-1 vector-2 length-2
415                             result predicate key svref)
416              (merge-vectors vector-1 length-1 vector-2 length-2
417                             result predicate key aref))))
418       ((and (csubtypep type (specifier-type 'sequence))
419             (find-class result-type nil))
420        (let* ((vector-1 (coerce sequence1 'vector))
421               (vector-2 (coerce sequence2 'vector))
422               (length-1 (length vector-1))
423               (length-2 (length vector-2))
424               (temp (make-array (+ length-1 length-2)))
425               (result (make-sequence result-type (+ length-1 length-2))))
426          (declare (vector vector-1 vector-2) (fixnum length-1 length-2))
427          (merge-vectors vector-1 length-1 vector-2 length-2
428                         temp predicate key aref)
429          (replace result temp)
430          result))
431       (t (bad-sequence-type-error result-type)))))