1 | ;;; -*- Log: code.log; Package: Lisp -*- |
---|
2 | ;;; |
---|
3 | ;;; ********************************************************************** |
---|
4 | ;;; This code was written as part of the CMU Common Lisp project at |
---|
5 | ;;; Carnegie Mellon University, and has been placed in the public domain. |
---|
6 | ;;; |
---|
7 | (ext:file-comment |
---|
8 | "$Header: src/code/sort.lisp $") |
---|
9 | ;;; |
---|
10 | ;;; ********************************************************************** |
---|
11 | ;;; |
---|
12 | ;;; Sort functions for Spice Lisp |
---|
13 | ;;; these functions are part of the standard spice lisp environment. |
---|
14 | ;;; |
---|
15 | ;;; Written by Jim Large |
---|
16 | ;;; Hacked on and maintained by Skef Wholey |
---|
17 | ;;; Rewritten by Bill Chiles |
---|
18 | ;;; |
---|
19 | ;;; ******************************************************************* |
---|
20 | |
---|
21 | (in-package "LISP") |
---|
22 | (intl:textdomain "cmucl") |
---|
23 | |
---|
24 | (export '(sort stable-sort merge)) |
---|
25 | |
---|
26 | |
---|
27 | |
---|
28 | (defun sort (sequence predicate &key key) |
---|
29 | "Destructively sorts sequence. Predicate should returns non-Nil if |
---|
30 | Arg1 is to precede Arg2." |
---|
31 | (typecase sequence |
---|
32 | (simple-vector |
---|
33 | (if (> (the fixnum (length (the simple-vector sequence))) 0) |
---|
34 | (sort-simple-vector sequence predicate key) |
---|
35 | sequence)) |
---|
36 | (list |
---|
37 | (sort-list sequence predicate key)) |
---|
38 | (vector |
---|
39 | (if (> (the fixnum (length sequence)) 0) |
---|
40 | (sort-vector sequence predicate key) |
---|
41 | sequence)) |
---|
42 | (t |
---|
43 | (error 'simple-type-error |
---|
44 | :datum sequence |
---|
45 | :expected-type 'sequence |
---|
46 | :format-control (intl:gettext "~S is not a sequence.") |
---|
47 | :format-arguments (list sequence))))) |
---|
48 | |
---|
49 | |
---|
50 | |
---|
51 | ;;; Sorting Vectors |
---|
52 | |
---|
53 | ;;; Sorting is done with a heap sort. |
---|
54 | |
---|
55 | (eval-when (compile eval) |
---|
56 | |
---|
57 | ;;; HEAPIFY, assuming both sons of root are heaps, percolates the root element |
---|
58 | ;;; through the sons to form a heap at root. Root and max are zero based |
---|
59 | ;;; coordinates, but the heap algorithm only works on arrays indexed from 1 |
---|
60 | ;;; through N (not 0 through N-1); This is because a root at I has sons at 2*I |
---|
61 | ;;; and 2*I+1 which does not work for a root at 0. Because of this, boundaries, |
---|
62 | ;;; roots, and termination are computed using 1..N indexes. |
---|
63 | |
---|
64 | (defmacro heapify (seq vector-ref root max pred key) |
---|
65 | (let ((heap-root (gensym)) (heap-max (gensym)) (root-ele (gensym)) |
---|
66 | (root-key (gensym)) (heap-max/2 (gensym)) (heap-l-son (gensym)) |
---|
67 | (one-son (gensym)) (one-son-ele (gensym)) (one-son-key (gensym)) |
---|
68 | (r-son-ele (gensym)) (r-son-key (gensym)) (var-root (gensym))) |
---|
69 | `(let* ((,var-root ,root) ; necessary to not clobber calling root var. |
---|
70 | (,heap-root (1+ ,root)) |
---|
71 | (,heap-max (1+ ,max)) |
---|
72 | (,root-ele (,vector-ref ,seq ,root)) |
---|
73 | (,root-key (apply-key ,key ,root-ele)) |
---|
74 | (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2) |
---|
75 | (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2)) |
---|
76 | (loop |
---|
77 | (if (> ,heap-root ,heap-max/2) (return)) |
---|
78 | (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root) |
---|
79 | ;; l-son index in seq (0..N-1) is one less than heap computation |
---|
80 | (,one-son (1- ,heap-l-son)) |
---|
81 | (,one-son-ele (,vector-ref ,seq ,one-son)) |
---|
82 | (,one-son-key (apply-key ,key ,one-son-ele))) |
---|
83 | (declare (fixnum ,heap-l-son ,one-son)) |
---|
84 | (if (< ,heap-l-son ,heap-max) |
---|
85 | ;; there is a right son. |
---|
86 | (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son)) |
---|
87 | (,r-son-key (apply-key ,key ,r-son-ele))) |
---|
88 | ;; choose the greater of the two sons. |
---|
89 | (when (funcall ,pred ,one-son-key ,r-son-key) |
---|
90 | (setf ,one-son ,heap-l-son) |
---|
91 | (setf ,one-son-ele ,r-son-ele) |
---|
92 | (setf ,one-son-key ,r-son-key)))) |
---|
93 | ;; if greater son is less than root, then we've formed a heap again. |
---|
94 | (if (funcall ,pred ,one-son-key ,root-key) (return)) |
---|
95 | ;; else put greater son at root and make greater son node be the root. |
---|
96 | (setf (,vector-ref ,seq ,var-root) ,one-son-ele) |
---|
97 | (setf ,heap-root (1+ ,one-son)) ; one plus to be in heap coordinates. |
---|
98 | (setf ,var-root ,one-son))) ; actual index into vector for root ele. |
---|
99 | ;; now really put percolated value into heap at the appropriate root node. |
---|
100 | (setf (,vector-ref ,seq ,var-root) ,root-ele)))) |
---|
101 | |
---|
102 | |
---|
103 | ;;; BUILD-HEAP rearranges seq elements into a heap to start heap sorting. |
---|
104 | (defmacro build-heap (seq type len-1 pred key) |
---|
105 | (let ((i (gensym))) |
---|
106 | `(do ((,i (floor ,len-1 2) (1- ,i))) |
---|
107 | ((minusp ,i) ,seq) |
---|
108 | (declare (fixnum ,i)) |
---|
109 | (heapify ,seq ,type ,i ,len-1 ,pred ,key)))) |
---|
110 | |
---|
111 | ) ; eval-when |
---|
112 | |
---|
113 | |
---|
114 | ;;; Make simple-vector and miscellaneous vector sorting functions. |
---|
115 | (macrolet ((frob-rob (fun-name vector-ref) |
---|
116 | `(defun ,fun-name (seq pred key) |
---|
117 | (let ((len-1 (1- (length (the vector seq))))) |
---|
118 | (declare (fixnum len-1)) |
---|
119 | (build-heap seq ,vector-ref len-1 pred key) |
---|
120 | (do* ((i len-1 i-1) |
---|
121 | (i-1 (1- i) (1- i-1))) |
---|
122 | ((zerop i) seq) |
---|
123 | (declare (fixnum i i-1)) |
---|
124 | (rotatef (,vector-ref seq 0) (,vector-ref seq i)) |
---|
125 | (heapify seq ,vector-ref 0 i-1 pred key)))))) |
---|
126 | |
---|
127 | (frob-rob sort-vector aref) |
---|
128 | |
---|
129 | (frob-rob sort-simple-vector svref)) |
---|
130 | |
---|
131 | |
---|
132 | |
---|
133 | ;;;; Stable Sorting |
---|
134 | |
---|
135 | (defun stable-sort (sequence predicate &key key) |
---|
136 | "Destructively sorts sequence. Predicate should returns non-Nil if |
---|
137 | Arg1 is to precede Arg2." |
---|
138 | (typecase sequence |
---|
139 | (simple-vector |
---|
140 | (stable-sort-simple-vector sequence predicate key)) |
---|
141 | (list |
---|
142 | (sort-list sequence predicate key)) |
---|
143 | (vector |
---|
144 | (stable-sort-vector sequence predicate key)) |
---|
145 | (t |
---|
146 | (error 'simple-type-error |
---|
147 | :datum sequence |
---|
148 | :expected-type 'sequence |
---|
149 | :format-control (intl:gettext "~S is not a sequence.") |
---|
150 | :format-arguments (list sequence))))) |
---|
151 | |
---|
152 | |
---|
153 | ;;; Stable Sorting Lists |
---|
154 | |
---|
155 | |
---|
156 | ;;; APPLY-PRED saves us a function call sometimes. |
---|
157 | (eval-when (compile eval) |
---|
158 | (defmacro apply-pred (one two pred key) |
---|
159 | `(if ,key |
---|
160 | (funcall ,pred (funcall ,key ,one) |
---|
161 | (funcall ,key ,two)) |
---|
162 | (funcall ,pred ,one ,two))) |
---|
163 | ) ; eval-when |
---|
164 | |
---|
165 | |
---|
166 | ;;; MERGE-LISTS* originally written by Jim Large. |
---|
167 | ;;; modified to return a pointer to the end of the result |
---|
168 | ;;; and to not cons header each time its called. |
---|
169 | ;;; It destructively merges list-1 with list-2. In the resulting |
---|
170 | ;;; list, elements of list-2 are guaranteed to come after equal elements |
---|
171 | ;;; of list-1. |
---|
172 | (defun merge-lists* (list-1 list-2 pred key |
---|
173 | &optional (merge-lists-header (list :header))) |
---|
174 | (do* ((result merge-lists-header) |
---|
175 | (P result)) ; P points to last cell of result |
---|
176 | ((or (null list-1) (null list-2)) ; done when either list used up |
---|
177 | (if (null list-1) ; in which case, append the |
---|
178 | (rplacd p list-2) ; other list |
---|
179 | (rplacd p list-1)) |
---|
180 | (do ((drag p lead) |
---|
181 | (lead (cdr p) (cdr lead))) |
---|
182 | ((null lead) |
---|
183 | (values (prog1 (cdr result) ; return the result sans header |
---|
184 | (rplacd result nil)) ; (free memory, be careful) |
---|
185 | drag)))) ; and return pointer to last element |
---|
186 | (cond ((apply-pred (car list-2) (car list-1) pred key) |
---|
187 | (rplacd p list-2) ; append the lesser list to last cell of |
---|
188 | (setq p (cdr p)) ; result. Note: test must bo done for |
---|
189 | (pop list-2)) ; list-2 < list-1 so merge will be |
---|
190 | (T (rplacd p list-1) ; stable for list-1 |
---|
191 | (setq p (cdr p)) |
---|
192 | (pop list-1))))) |
---|
193 | |
---|
194 | |
---|
195 | ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over |
---|
196 | ;;; the list grabbing one element at a time and merging it with the next one |
---|
197 | ;;; form pairs of sorted elements. Then n is doubled, and elements are taken |
---|
198 | ;;; in runs of two, merging one run with the next to form quadruples of sorted |
---|
199 | ;;; elements. This continues until n is large enough that the inner loop only |
---|
200 | ;;; runs for one iteration; that is, there are only two runs that can be merged, |
---|
201 | ;;; the first run starting at the beginning of the list, and the second being |
---|
202 | ;;; the remaining elements. |
---|
203 | |
---|
204 | (defun sort-list (list pred key) |
---|
205 | (let ((head (cons :header list)) ; head holds on to everything |
---|
206 | (n 1) ; bottom-up size of lists to be merged |
---|
207 | unsorted ; unsorted is the remaining list to be |
---|
208 | ; broken into n size lists and merged |
---|
209 | list-1 ; list-1 is one length n list to be merged |
---|
210 | last ; last points to the last visited cell |
---|
211 | (merge-lists-header (list :header))) |
---|
212 | (declare (fixnum n)) |
---|
213 | (loop |
---|
214 | ;; start collecting runs of n at the first element |
---|
215 | (setf unsorted (cdr head)) |
---|
216 | ;; tack on the first merge of two n-runs to the head holder |
---|
217 | (setf last head) |
---|
218 | (let ((n-1 (1- n))) |
---|
219 | (declare (fixnum n-1)) |
---|
220 | (loop |
---|
221 | (setf list-1 unsorted) |
---|
222 | (let ((temp (nthcdr n-1 list-1)) |
---|
223 | list-2) |
---|
224 | (cond (temp |
---|
225 | ;; there are enough elements for a second run |
---|
226 | (setf list-2 (cdr temp)) |
---|
227 | (setf (cdr temp) nil) |
---|
228 | (setf temp (nthcdr n-1 list-2)) |
---|
229 | (cond (temp |
---|
230 | (setf unsorted (cdr temp)) |
---|
231 | (setf (cdr temp) nil)) |
---|
232 | ;; the second run goes off the end of the list |
---|
233 | (t (setf unsorted nil))) |
---|
234 | (multiple-value-bind (merged-head merged-last) |
---|
235 | (merge-lists* list-1 list-2 pred key |
---|
236 | merge-lists-header) |
---|
237 | (setf (cdr last) merged-head) |
---|
238 | (setf last merged-last)) |
---|
239 | (if (null unsorted) (return))) |
---|
240 | ;; if there is only one run, then tack it on to the end |
---|
241 | (t (setf (cdr last) list-1) |
---|
242 | (return))))) |
---|
243 | (setf n (ash n 1)) ; (+ n n) |
---|
244 | ;; If the inner loop only executed once, then there were only enough |
---|
245 | ;; elements for two runs given n, so all the elements have been merged |
---|
246 | ;; into one list. This may waste one outer iteration to realize. |
---|
247 | (if (eq list-1 (cdr head)) |
---|
248 | (return list-1)))))) |
---|
249 | |
---|
250 | |
---|
251 | |
---|
252 | ;;; Stable Sort Vectors |
---|
253 | |
---|
254 | ;;; Stable sorting vectors is done with the same algorithm used for lists, |
---|
255 | ;;; using a temporary vector to merge back and forth between it and the |
---|
256 | ;;; given vector to sort. |
---|
257 | |
---|
258 | |
---|
259 | (eval-when (compile eval) |
---|
260 | |
---|
261 | ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences, |
---|
262 | ;;; start-1 (inclusive) ... end-1 (exclusive) and |
---|
263 | ;;; end-1 (inclusive) ... end-2 (exclusive), |
---|
264 | ;;; and merges them into a target vector starting at index start-1. |
---|
265 | |
---|
266 | (defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2 |
---|
267 | pred key source-ref target-ref) |
---|
268 | (let ((i (gensym)) |
---|
269 | (j (gensym)) |
---|
270 | (target-i (gensym))) |
---|
271 | `(let ((,i ,start-1) |
---|
272 | (,j ,end-1) ; start-2 |
---|
273 | (,target-i ,start-1)) |
---|
274 | (declare (fixnum ,i ,j ,target-i)) |
---|
275 | (loop |
---|
276 | (cond ((= ,i ,end-1) |
---|
277 | (loop (if (= ,j ,end-2) (return)) |
---|
278 | (setf (,target-ref ,target ,target-i) |
---|
279 | (,source-ref ,source ,j)) |
---|
280 | (incf ,target-i) |
---|
281 | (incf ,j)) |
---|
282 | (return)) |
---|
283 | ((= ,j ,end-2) |
---|
284 | (loop (if (= ,i ,end-1) (return)) |
---|
285 | (setf (,target-ref ,target ,target-i) |
---|
286 | (,source-ref ,source ,i)) |
---|
287 | (incf ,target-i) |
---|
288 | (incf ,i)) |
---|
289 | (return)) |
---|
290 | ((apply-pred (,source-ref ,source ,j) |
---|
291 | (,source-ref ,source ,i) |
---|
292 | ,pred ,key) |
---|
293 | (setf (,target-ref ,target ,target-i) |
---|
294 | (,source-ref ,source ,j)) |
---|
295 | (incf ,j)) |
---|
296 | (t (setf (,target-ref ,target ,target-i) |
---|
297 | (,source-ref ,source ,i)) |
---|
298 | (incf ,i))) |
---|
299 | (incf ,target-i))))) |
---|
300 | |
---|
301 | |
---|
302 | ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but |
---|
303 | ;;; it uses a temporary vector. Direction determines whether we are merging |
---|
304 | ;;; into the temporary (T) or back into the given vector (NIL). |
---|
305 | |
---|
306 | (defmacro vector-merge-sort (vector pred key vector-ref) |
---|
307 | (let ((vector-len (gensym)) (n (gensym)) |
---|
308 | (direction (gensym)) (unsorted (gensym)) |
---|
309 | (start-1 (gensym)) (end-1 (gensym)) |
---|
310 | (end-2 (gensym)) (i (gensym)) |
---|
311 | (temp-vector (gensym))) |
---|
312 | `(let* ((,vector-len (length (the vector ,vector))) |
---|
313 | (,n 1) ; bottom-up size of contiguous runs to be merged |
---|
314 | (,direction t) ; t vector --> temp nil temp --> vector |
---|
315 | (,temp-vector (make-array ,vector-len)) |
---|
316 | (,unsorted 0) ; unsorted..vector-len are the elements that need |
---|
317 | ; to be merged for a given n |
---|
318 | (,start-1 0)) ; one n-len subsequence to be merged with the next |
---|
319 | (declare (fixnum ,vector-len ,n ,unsorted ,start-1) |
---|
320 | (type simple-vector ,temp-vector)) |
---|
321 | (loop |
---|
322 | ;; for each n, we start taking n-runs from the start of the vector |
---|
323 | (setf ,unsorted 0) |
---|
324 | (loop |
---|
325 | (setf ,start-1 ,unsorted) |
---|
326 | (let ((,end-1 (+ ,start-1 ,n))) |
---|
327 | (declare (fixnum ,end-1)) |
---|
328 | (cond ((< ,end-1 ,vector-len) |
---|
329 | ;; there are enough elements for a second run |
---|
330 | (let ((,end-2 (+ ,end-1 ,n))) |
---|
331 | (declare (fixnum ,end-2)) |
---|
332 | (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) |
---|
333 | (setf ,unsorted ,end-2) |
---|
334 | (if ,direction |
---|
335 | (stable-sort-merge-vectors* |
---|
336 | ,vector ,temp-vector |
---|
337 | ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) |
---|
338 | (stable-sort-merge-vectors* |
---|
339 | ,temp-vector ,vector |
---|
340 | ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) |
---|
341 | (if (= ,unsorted ,vector-len) (return)))) |
---|
342 | ;; if there is only one run, copy those elements to the end |
---|
343 | (t (if ,direction |
---|
344 | (do ((,i ,start-1 (1+ ,i))) |
---|
345 | ((= ,i ,vector-len)) |
---|
346 | (declare (fixnum ,i)) |
---|
347 | (setf (svref ,temp-vector ,i) |
---|
348 | (,vector-ref ,vector ,i))) |
---|
349 | (do ((,i ,start-1 (1+ ,i))) |
---|
350 | ((= ,i ,vector-len)) |
---|
351 | (declare (fixnum ,i)) |
---|
352 | (setf (,vector-ref ,vector ,i) |
---|
353 | (svref ,temp-vector ,i)))) |
---|
354 | (return))))) |
---|
355 | ;; If the inner loop only executed once, then there were only enough |
---|
356 | ;; elements for two subsequences given n, so all the elements have |
---|
357 | ;; been merged into one list. Start-1 will have remained 0 upon exit. |
---|
358 | (when (zerop ,start-1) |
---|
359 | (if ,direction |
---|
360 | ;; if we just merged into the temporary, copy it all back |
---|
361 | ;; to the given vector. |
---|
362 | (dotimes (,i ,vector-len) |
---|
363 | (setf (,vector-ref ,vector ,i) |
---|
364 | (svref ,temp-vector ,i)))) |
---|
365 | (return ,vector)) |
---|
366 | (setf ,n (ash ,n 1)) ; (* 2 n) |
---|
367 | (setf ,direction (not ,direction)))))) |
---|
368 | |
---|
369 | ) ; eval-when |
---|
370 | |
---|
371 | |
---|
372 | (defun stable-sort-simple-vector (vector pred key) |
---|
373 | (declare (simple-vector vector)) |
---|
374 | (vector-merge-sort vector pred key svref)) |
---|
375 | |
---|
376 | (defun stable-sort-vector (vector pred key) |
---|
377 | (vector-merge-sort vector pred key aref)) |
---|
378 | |
---|
379 | |
---|
380 | |
---|
381 | ;;;; Merge |
---|
382 | |
---|
383 | (eval-when (compile eval) |
---|
384 | |
---|
385 | ;;; MERGE-VECTORS returns a new vector which contains an interleaving |
---|
386 | ;;; of the elements of vector-1 and vector-2. Elements from vector-2 are |
---|
387 | ;;; chosen only if they are strictly less than elements of vector-1, |
---|
388 | ;;; (pred elt-2 elt-1), as specified in the manual. |
---|
389 | |
---|
390 | (defmacro merge-vectors (vector-1 length-1 vector-2 length-2 |
---|
391 | result-vector pred key access) |
---|
392 | (let ((result-i (gensym)) |
---|
393 | (i (gensym)) |
---|
394 | (j (gensym))) |
---|
395 | `(let* ((,result-i 0) |
---|
396 | (,i 0) |
---|
397 | (,j 0)) |
---|
398 | (declare (fixnum ,result-i ,i ,j)) |
---|
399 | (loop |
---|
400 | (cond ((= ,i ,length-1) |
---|
401 | (loop (if (= ,j ,length-2) (return)) |
---|
402 | (setf (,access ,result-vector ,result-i) |
---|
403 | (,access ,vector-2 ,j)) |
---|
404 | (incf ,result-i) |
---|
405 | (incf ,j)) |
---|
406 | (return ,result-vector)) |
---|
407 | ((= ,j ,length-2) |
---|
408 | (loop (if (= ,i ,length-1) (return)) |
---|
409 | (setf (,access ,result-vector ,result-i) |
---|
410 | (,access ,vector-1 ,i)) |
---|
411 | (incf ,result-i) |
---|
412 | (incf ,i)) |
---|
413 | (return ,result-vector)) |
---|
414 | ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) |
---|
415 | ,pred ,key) |
---|
416 | (setf (,access ,result-vector ,result-i) |
---|
417 | (,access ,vector-2 ,j)) |
---|
418 | (incf ,j)) |
---|
419 | (t (setf (,access ,result-vector ,result-i) |
---|
420 | (,access ,vector-1 ,i)) |
---|
421 | (incf ,i))) |
---|
422 | (incf ,result-i))))) |
---|
423 | |
---|
424 | ) ; eval-when |
---|
425 | |
---|
426 | (defun merge (result-type sequence1 sequence2 predicate &key key) |
---|
427 | "The sequences Sequence1 and Sequence2 are destructively merged into |
---|
428 | a sequence of type Result-Type using the Predicate to order the elements." |
---|
429 | (cond ((or (eq result-type 'list) |
---|
430 | (subtypep result-type 'list)) |
---|
431 | ;; Check the length of result-type and the sequence for |
---|
432 | ;; consistency |
---|
433 | (let ((s1 (coerce sequence1 'list)) |
---|
434 | (s2 (coerce sequence2 'list)) |
---|
435 | (type (specifier-type result-type))) |
---|
436 | (cond ((type= type (specifier-type 'list)) |
---|
437 | (values (merge-lists* s1 s2 predicate key))) |
---|
438 | ((eq type *empty-type*) |
---|
439 | (bad-sequence-type-error nil)) |
---|
440 | ((type= type (specifier-type 'null)) |
---|
441 | (if (and (null s1) (null s2)) |
---|
442 | nil |
---|
443 | (sequence-length-error type |
---|
444 | (+ (length s1) (length s2))))) |
---|
445 | ((csubtypep (specifier-type '(cons nil t)) type) |
---|
446 | (if (and (null s1) (null s2)) |
---|
447 | (sequence-length-error type 0) |
---|
448 | (values (merge-lists* s1 s2 predicate key)))) |
---|
449 | (t |
---|
450 | (values (merge-lists* s1 s2 predicate key)))))) |
---|
451 | |
---|
452 | ((subtypep result-type 'vector) |
---|
453 | (let* ((vector-1 (coerce sequence1 'vector)) |
---|
454 | (vector-2 (coerce sequence2 'vector)) |
---|
455 | (length-1 (length vector-1)) |
---|
456 | (length-2 (length vector-2)) |
---|
457 | (result (make-sequence result-type (+ length-1 length-2)))) |
---|
458 | (declare (vector vector-1 vector-2) |
---|
459 | (fixnum length-1 length-2)) |
---|
460 | (if (and (simple-vector-p result) |
---|
461 | (simple-vector-p vector-1) |
---|
462 | (simple-vector-p vector-2)) |
---|
463 | (merge-vectors vector-1 length-1 vector-2 length-2 |
---|
464 | result predicate key svref) |
---|
465 | (merge-vectors vector-1 length-1 vector-2 length-2 |
---|
466 | result predicate key aref)))) |
---|
467 | (t |
---|
468 | (bad-sequence-type-error result-type)))) |
---|