mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-15 05:43:19 -08:00
Reimplemented seqlib.lsp using macros that speed up calling predicats and key functions.
This commit is contained in:
Juan Jose Garcia Ripoll
parent
9ccd82b179
commit
1e7935ea46
1 changed files with 248 additions and 224 deletions
|
|
@ -24,16 +24,15 @@
|
|||
((vectorp sequence) (list 'vector (array-element-type sequence)))
|
||||
(t (error "~S is not a sequence." sequence))))
|
||||
|
||||
(defun call-test (test test-not item keyx)
|
||||
(declare (si::c-local))
|
||||
(cond (test (funcall test item keyx))
|
||||
(test-not (not (funcall test-not item keyx)))
|
||||
(t (eql item keyx))))
|
||||
|
||||
(defun test-error()
|
||||
(declare (si::c-local))
|
||||
(error "both test and test-not are supplied"))
|
||||
|
||||
(defun unsafe-funcall1 (f x)
|
||||
(declare (function f)
|
||||
(optimize (speed 3) (safety 0)))
|
||||
(funcall f x))
|
||||
|
||||
(defun sequence-limits (start end seq)
|
||||
(declare (si::c-local))
|
||||
(let* (x0 x1 (l (length seq)))
|
||||
|
|
@ -57,7 +56,33 @@
|
|||
start end))
|
||||
(values x0 x1)))
|
||||
|
||||
(eval-when (compile #+ecl-min eval)
|
||||
(eval-when (:compile-toplevel :execute)
|
||||
(defmacro with-predicate ((predicate) &body body)
|
||||
`(let ((,predicate (si::coerce-to-function ,predicate)))
|
||||
(macrolet ((,predicate (&rest args)
|
||||
`(locally (declare (optimize (safety 0) (speed 3)))
|
||||
(funcall (the function ,',predicate) ,@args))))
|
||||
,@body)))
|
||||
(defmacro with-key ((akey) &body body)
|
||||
`(let ((,akey (if ,akey (si::coerce-to-function ,akey) #'identity)))
|
||||
(macrolet ((,akey (value)
|
||||
`(locally (declare (optimize (safety 0) (speed 3)))
|
||||
(funcall (the function ,',akey) ,value))))
|
||||
,@body)))
|
||||
(defmacro with-tests (&whole whole (test test-not &optional key) &body body)
|
||||
(when key
|
||||
(setf body `((with-key (,key) ,@body))))
|
||||
`(let ((,test (if ,test (si::coerce-to-function ,test)))
|
||||
(,test-not (if ,test-not (si::coerce-to-function ,test-not))))
|
||||
(and test test-not (test-error))
|
||||
(macrolet ((compare (v1 v2)
|
||||
`(locally (declare (optimize (safety 0) (speed 3)))
|
||||
(cond (test (funcall (the function test) ,v1 ,v2))
|
||||
(test-not (not (funcall (the function test-not)
|
||||
,v1 ,v2)))
|
||||
(t (eql ,v1 ,v2))))
|
||||
))
|
||||
,@body)))
|
||||
(defmacro with-start-end (start end seq &body body)
|
||||
`(multiple-value-bind (,start ,end)
|
||||
(sequence-limits ,start ,end ,seq)
|
||||
|
|
@ -70,16 +95,16 @@
|
|||
end
|
||||
key (initial-value nil ivsp))
|
||||
(with-start-end start end sequence
|
||||
(unless key (setq key #'identity))
|
||||
(with-key (key)
|
||||
(cond ((not from-end)
|
||||
(when (null ivsp)
|
||||
(when (>= start end)
|
||||
(return-from reduce (funcall function)))
|
||||
(setq initial-value (funcall key (elt sequence start)))
|
||||
(setq initial-value (key (elt sequence start)))
|
||||
(incf start))
|
||||
(do ((x initial-value
|
||||
(funcall function x
|
||||
(prog1 (funcall key (elt sequence start))
|
||||
(prog1 (key (elt sequence start))
|
||||
(incf start)))))
|
||||
((>= start end) x)))
|
||||
(t
|
||||
|
|
@ -89,10 +114,10 @@
|
|||
(decf end)
|
||||
(setq initial-value (elt sequence end)))
|
||||
(do ((x initial-value (funcall function
|
||||
(funcall key (elt sequence end))
|
||||
(key (elt sequence end))
|
||||
x)))
|
||||
((>= start end) x)
|
||||
(decf end))))))
|
||||
(decf end)))))))
|
||||
|
||||
(defun fill (sequence item &key (start 0) end)
|
||||
(with-start-end start end sequence
|
||||
|
|
@ -103,7 +128,7 @@
|
|||
|
||||
(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
|
||||
(with-start-end start1 end1 sequence1
|
||||
(with-start-end start2 end2 sequence2
|
||||
(with-start-end start2 end2 sequence2
|
||||
(if (and (eq sequence1 sequence2)
|
||||
(> start1 start2))
|
||||
(do* ((i 0 (1+ i))
|
||||
|
|
@ -139,6 +164,7 @@
|
|||
;;; If VARIANTSP is NIL, the variants -IF and -IF-NOT are not generated.
|
||||
|
||||
(eval-when (eval compile)
|
||||
|
||||
(defmacro defseq (f args countp everywherep variantsp normal-form &optional from-end-form)
|
||||
`(macrolet
|
||||
((do-defseq (f args countp everywherep)
|
||||
|
|
@ -146,8 +172,8 @@
|
|||
normal-form
|
||||
(i-in-range '(and (<= start i) (< i end)))
|
||||
(x '(elt sequence i))
|
||||
(keyx `(funcall key ,x))
|
||||
(satisfies-the-test `(call-test test test-not item ,keyx))
|
||||
(keyx `(key ,x))
|
||||
(satisfies-the-test `(compare item ,keyx))
|
||||
(number-satisfied
|
||||
`(n (internal-count item sequence
|
||||
:from-end from-end
|
||||
|
|
@ -177,8 +203,8 @@
|
|||
(list '&aux '(l (length sequence)))
|
||||
nil))
|
||||
,@(if everywherep '((declare (fixnum l))))
|
||||
(unless key (setq key #'identity))
|
||||
(with-start-end start end sequence
|
||||
(with-tests (test test-not key)
|
||||
(with-start-end start end sequence
|
||||
;; FIXME! We use that no object have more than
|
||||
;; MOST-POSITIVE-FIXNUM elements.
|
||||
(let ,@(if countp
|
||||
|
|
@ -191,8 +217,7 @@
|
|||
(t count))))))
|
||||
,@(if countp '((declare (fixnum count))))
|
||||
nil
|
||||
(and test test-not (test-error))
|
||||
(if from-end ,from-end-form ,normal-form)))))))
|
||||
(if from-end ,from-end-form ,normal-form))))))))
|
||||
(do-defseq ,f ,args ,countp ,everywherep)
|
||||
,@(if variantsp
|
||||
`((defun ,(intern (si:base-string-concatenate (string f) "-IF")
|
||||
|
|
@ -202,9 +227,9 @@
|
|||
(start 0) end
|
||||
key
|
||||
,@(if countp '(count)))
|
||||
(,f ,@args predicate sequence
|
||||
(,f ,@args (si::coerce-to-function predicate) sequence
|
||||
:from-end from-end
|
||||
:test #'funcall
|
||||
:test #'unsafe-funcall1
|
||||
:start start :end end
|
||||
,@(if countp '(:count count))
|
||||
:key key))
|
||||
|
|
@ -213,9 +238,9 @@
|
|||
(,@args predicate sequence
|
||||
&key from-end (start 0) end
|
||||
key ,@(if countp '(count)))
|
||||
(,f ,@args predicate sequence
|
||||
(,f ,@args (si::coerce-to-function predicate) sequence
|
||||
:from-end from-end
|
||||
:test-not #'funcall
|
||||
:test-not #'unsafe-funcall1
|
||||
:start start :end end
|
||||
,@(if countp '(:count count))
|
||||
:key key))
|
||||
|
|
@ -237,7 +262,7 @@
|
|||
((or (>= i end) (>= j count) (endp l))
|
||||
(nreconc l1 l))
|
||||
(declare (fixnum i j))
|
||||
(if (call-test test test-not item (funcall key (car l)))
|
||||
(if (compare item (key (car l)))
|
||||
(incf j)
|
||||
(push (car l) l1))
|
||||
(pop l)))
|
||||
|
|
@ -267,7 +292,7 @@
|
|||
(do ((i start (1+ i)) (j 0))
|
||||
((or (>= i end) (>= j count) (endp (cdr l))) (cdr l0))
|
||||
(declare (fixnum i j))
|
||||
(cond ((call-test test test-not item (funcall key (cadr l)))
|
||||
(cond ((compare item (key (cadr l)))
|
||||
(incf j)
|
||||
(rplacd l (cddr l)))
|
||||
(t (setq l (cdr l))))))
|
||||
|
|
@ -388,81 +413,80 @@ Returns a copy of SEQUENCE without duplicated elements."
|
|||
(start 0) (end (length sequence)) (from-end nil))
|
||||
Destructive REMOVE-DUPLICATES. SEQUENCE may be destroyed."
|
||||
(declare (fixnum l))
|
||||
(and test test-not (test-error))
|
||||
(when (and (listp sequence) (not from-end) (null start) (null end))
|
||||
(when (endp sequence) (return-from delete-duplicates nil))
|
||||
(do ((l sequence))
|
||||
((endp (cdr l))
|
||||
(return-from delete-duplicates sequence))
|
||||
(cond ((member1 (car l) (cdr l) test test-not key)
|
||||
(rplaca l (cadr l))
|
||||
(rplacd l (cddr l)))
|
||||
(t (setq l (cdr l))))))
|
||||
(with-start-end start end sequence
|
||||
(unless key (setq key #'identity))
|
||||
(if (not from-end)
|
||||
(do ((n 0)
|
||||
(i start (1+ i)))
|
||||
((>= i end)
|
||||
(do ((newseq (make-sequence (seqtype sequence)
|
||||
(the fixnum (- l n))))
|
||||
(i 0 (1+ i))
|
||||
(j 0))
|
||||
((>= i l) newseq)
|
||||
(declare (fixnum i j))
|
||||
(cond ((and (<= start i)
|
||||
(< i end)
|
||||
(position (funcall key (elt sequence i))
|
||||
sequence
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start (the fixnum (1+ i))
|
||||
:end end
|
||||
:key key)))
|
||||
(t
|
||||
(setf (elt newseq j) (elt sequence i))
|
||||
(incf j)))))
|
||||
(declare (fixnum n i))
|
||||
(when (position (funcall key (elt sequence i))
|
||||
sequence
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start (the fixnum (1+ i))
|
||||
:end end
|
||||
:key key)
|
||||
(incf n)))
|
||||
(do ((n 0)
|
||||
(i (1- end) (1- i)))
|
||||
((< i start)
|
||||
(do ((newseq (make-sequence (seqtype sequence)
|
||||
(the fixnum (- l n))))
|
||||
(i (1- l) (1- i))
|
||||
(j (- (the fixnum (1- l)) n)))
|
||||
((< i 0) newseq)
|
||||
(declare (fixnum i j))
|
||||
(cond ((and (<= start i)
|
||||
(< i end)
|
||||
(position (funcall key (elt sequence i))
|
||||
sequence
|
||||
:from-end t
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start start
|
||||
:end i
|
||||
:key key)))
|
||||
(t
|
||||
(setf (elt newseq j) (elt sequence i))
|
||||
(decf j)))))
|
||||
(declare (fixnum n i))
|
||||
(when (position (funcall key (elt sequence i))
|
||||
sequence
|
||||
:from-end t
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start start
|
||||
:end i
|
||||
:key key)
|
||||
(incf n))))))
|
||||
(with-tests (test test-not key)
|
||||
(when (and (listp sequence) (not from-end) (null start) (null end))
|
||||
(when (endp sequence) (return-from delete-duplicates nil))
|
||||
(do ((l sequence))
|
||||
((endp (cdr l))
|
||||
(return-from delete-duplicates sequence))
|
||||
(cond ((member1 (car l) (cdr l) test test-not key)
|
||||
(rplaca l (cadr l))
|
||||
(rplacd l (cddr l)))
|
||||
(t (setq l (cdr l))))))
|
||||
(with-start-end start end sequence
|
||||
(if (not from-end)
|
||||
(do ((n 0)
|
||||
(i start (1+ i)))
|
||||
((>= i end)
|
||||
(do ((newseq (make-sequence (seqtype sequence)
|
||||
(the fixnum (- l n))))
|
||||
(i 0 (1+ i))
|
||||
(j 0))
|
||||
((>= i l) newseq)
|
||||
(declare (fixnum i j))
|
||||
(cond ((and (<= start i)
|
||||
(< i end)
|
||||
(position (key (elt sequence i))
|
||||
sequence
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start (the fixnum (1+ i))
|
||||
:end end
|
||||
:key key)))
|
||||
(t
|
||||
(setf (elt newseq j) (elt sequence i))
|
||||
(incf j)))))
|
||||
(declare (fixnum n i))
|
||||
(when (position (key (elt sequence i))
|
||||
sequence
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start (the fixnum (1+ i))
|
||||
:end end
|
||||
:key key)
|
||||
(incf n)))
|
||||
(do ((n 0)
|
||||
(i (1- end) (1- i)))
|
||||
((< i start)
|
||||
(do ((newseq (make-sequence (seqtype sequence)
|
||||
(the fixnum (- l n))))
|
||||
(i (1- l) (1- i))
|
||||
(j (- (the fixnum (1- l)) n)))
|
||||
((< i 0) newseq)
|
||||
(declare (fixnum i j))
|
||||
(cond ((and (<= start i)
|
||||
(< i end)
|
||||
(position (key (elt sequence i))
|
||||
sequence
|
||||
:from-end t
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start start
|
||||
:end i
|
||||
:key key)))
|
||||
(t
|
||||
(setf (elt newseq j) (elt sequence i))
|
||||
(decf j)))))
|
||||
(declare (fixnum n i))
|
||||
(when (position (key (elt sequence i))
|
||||
sequence
|
||||
:from-end t
|
||||
:test test
|
||||
:test-not test-not
|
||||
:start start
|
||||
:end i
|
||||
:key key)
|
||||
(incf n)))))))
|
||||
|
||||
|
||||
(defun mismatch (sequence1 sequence2
|
||||
|
|
@ -481,26 +505,24 @@ element that does not match."
|
|||
(and test test-not (test-error))
|
||||
(with-start-end start1 end1 sequence1
|
||||
(with-start-end start2 end2 sequence2
|
||||
(unless key (setq key #'identity))
|
||||
(if (not from-end)
|
||||
(do ((i1 start1 (1+ i1))
|
||||
(i2 start2 (1+ i2)))
|
||||
((or (>= i1 end1) (>= i2 end2))
|
||||
(if (and (>= i1 end1) (>= i2 end2)) nil i1))
|
||||
(declare (fixnum i1 i2))
|
||||
(unless (call-test test test-not
|
||||
(funcall key (elt sequence1 i1))
|
||||
(funcall key (elt sequence2 i2)))
|
||||
(return i1)))
|
||||
(do ((i1 (1- end1) (1- i1))
|
||||
(i2 (1- end2) (1- i2)))
|
||||
((or (< i1 start1) (< i2 start2))
|
||||
(if (and (< i1 start1) (< i2 start2)) nil (1+ i1)))
|
||||
(declare (fixnum i1 i2))
|
||||
(unless (call-test test test-not
|
||||
(funcall key (elt sequence1 i1))
|
||||
(funcall key (elt sequence2 i2)))
|
||||
(return (1+ i1))))))))
|
||||
(with-tests (test test-not key)
|
||||
(if (not from-end)
|
||||
(do ((i1 start1 (1+ i1))
|
||||
(i2 start2 (1+ i2)))
|
||||
((or (>= i1 end1) (>= i2 end2))
|
||||
(if (and (>= i1 end1) (>= i2 end2)) nil i1))
|
||||
(declare (fixnum i1 i2))
|
||||
(unless (compare (key (elt sequence1 i1))
|
||||
(key (elt sequence2 i2)))
|
||||
(return i1)))
|
||||
(do ((i1 (1- end1) (1- i1))
|
||||
(i2 (1- end2) (1- i2)))
|
||||
((or (< i1 start1) (< i2 start2))
|
||||
(if (and (< i1 start1) (< i2 start2)) nil (1+ i1)))
|
||||
(declare (fixnum i1 i2))
|
||||
(unless (compare (key (elt sequence1 i1))
|
||||
(key (elt sequence2 i2)))
|
||||
(return (1+ i1)))))))))
|
||||
|
||||
|
||||
(defun search (sequence1 sequence2
|
||||
|
|
@ -518,30 +540,28 @@ subsequence is found. Returns NIL otherwise."
|
|||
(and test test-not (test-error))
|
||||
(with-start-end start1 end1 sequence1
|
||||
(with-start-end start2 end2 sequence2
|
||||
(unless key (setq key #'identity))
|
||||
(if (not from-end)
|
||||
(loop
|
||||
(do ((i1 start1 (1+ i1))
|
||||
(i2 start2 (1+ i2)))
|
||||
((>= i1 end1) (return-from search start2))
|
||||
(declare (fixnum i1 i2))
|
||||
(when (>= i2 end2) (return-from search nil))
|
||||
(unless (call-test test test-not
|
||||
(funcall key (elt sequence1 i1))
|
||||
(funcall key (elt sequence2 i2)))
|
||||
(return nil)))
|
||||
(incf start2))
|
||||
(loop
|
||||
(do ((i1 (1- end1) (1- i1))
|
||||
(i2 (1- end2) (1- i2)))
|
||||
((< i1 start1) (return-from search (the fixnum (1+ i2))))
|
||||
(declare (fixnum i1 i2))
|
||||
(when (< i2 start2) (return-from search nil))
|
||||
(unless (call-test test test-not
|
||||
(funcall key (elt sequence1 i1))
|
||||
(funcall key (elt sequence2 i2)))
|
||||
(return nil)))
|
||||
(decf end2))))))
|
||||
(with-tests (test test-not key)
|
||||
(if (not from-end)
|
||||
(loop
|
||||
(do ((i1 start1 (1+ i1))
|
||||
(i2 start2 (1+ i2)))
|
||||
((>= i1 end1) (return-from search start2))
|
||||
(declare (fixnum i1 i2))
|
||||
(when (>= i2 end2) (return-from search nil))
|
||||
(unless (compare (key (elt sequence1 i1))
|
||||
(key (elt sequence2 i2)))
|
||||
(return nil)))
|
||||
(incf start2))
|
||||
(loop
|
||||
(do ((i1 (1- end1) (1- i1))
|
||||
(i2 (1- end2) (1- i2)))
|
||||
((< i1 start1) (return-from search (the fixnum (1+ i2))))
|
||||
(declare (fixnum i1 i2))
|
||||
(when (< i2 start2) (return-from search nil))
|
||||
(unless (compare (key (elt sequence1 i1))
|
||||
(key (elt sequence2 i2)))
|
||||
(return nil)))
|
||||
(decf end2)))))))
|
||||
|
||||
|
||||
(defun sort (sequence predicate &key key)
|
||||
|
|
@ -552,72 +572,75 @@ elements X and Y is arbitrary if both
|
|||
(FUNCALL TEST X Y)
|
||||
(FUNCALL TEST Y X)
|
||||
evaluates to NIL. See STABLE-SORT."
|
||||
(setf key (if key (si::coerce-to-function key) #'identity)
|
||||
predicate (si::coerce-to-function predicate))
|
||||
(if (listp sequence)
|
||||
(list-merge-sort sequence predicate key)
|
||||
(quick-sort sequence 0 (the fixnum (length sequence)) predicate key)))
|
||||
|
||||
|
||||
(defun list-merge-sort (l predicate key)
|
||||
(declare (si::c-local))
|
||||
(unless key (setq key #'identity))
|
||||
(declare (si::c-local)
|
||||
(optimize (safety 0) (speed 3))
|
||||
(function predicate key))
|
||||
(labels
|
||||
((sort (l)
|
||||
(prog ((i 0) left right l0 l1 key-left key-right)
|
||||
(declare (fixnum i))
|
||||
(setq i (length l))
|
||||
(cond ((< i 2) (return l))
|
||||
((= i 2)
|
||||
(setq key-left (funcall key (car l)))
|
||||
(setq key-right (funcall key (cadr l)))
|
||||
(cond ((funcall predicate key-left key-right) (return l))
|
||||
((funcall predicate key-right key-left)
|
||||
(return (nreverse l)))
|
||||
(t (return l)))))
|
||||
(setq i (floor i 2))
|
||||
(do ((j 1 (1+ j)) (l1 l (cdr l1)))
|
||||
((>= j i)
|
||||
(setq left l)
|
||||
(setq right (cdr l1))
|
||||
(rplacd l1 nil))
|
||||
(declare (fixnum j)))
|
||||
(setq left (sort left))
|
||||
(setq right (sort right))
|
||||
(cond ((endp left) (return right))
|
||||
((endp right) (return left)))
|
||||
(setq l0 (cons nil nil))
|
||||
(setq l1 l0)
|
||||
(setq key-left (funcall key (car left)))
|
||||
(setq key-right (funcall key (car right)))
|
||||
loop
|
||||
(cond ((funcall predicate key-left key-right) (go left))
|
||||
((funcall predicate key-right key-left) (go right))
|
||||
(t (go left)))
|
||||
left
|
||||
(rplacd l1 left)
|
||||
(setq l1 (cdr l1))
|
||||
(setq left (cdr left))
|
||||
(when (endp left)
|
||||
(rplacd l1 right)
|
||||
(return (cdr l0)))
|
||||
(setq key-left (funcall key (car left)))
|
||||
(go loop)
|
||||
right
|
||||
(rplacd l1 right)
|
||||
(setq l1 (cdr l1))
|
||||
(setq right (cdr right))
|
||||
(when (endp right)
|
||||
(rplacd l1 left)
|
||||
(return (cdr l0)))
|
||||
(setq key-right (funcall key (car right)))
|
||||
(go loop))))
|
||||
(sort l)))
|
||||
((sort (l)
|
||||
(prog ((i 0) left right l0 l1 key-left key-right)
|
||||
(declare (fixnum i))
|
||||
(setq i (length l))
|
||||
(cond ((< i 2) (return l))
|
||||
((= i 2)
|
||||
(setq key-left (funcall key (car l)))
|
||||
(setq key-right (funcall key (cadr l)))
|
||||
(cond ((funcall predicate key-left key-right) (return l))
|
||||
((funcall predicate key-right key-left)
|
||||
(return (nreverse l)))
|
||||
(t (return l)))))
|
||||
(setq i (floor i 2))
|
||||
(do ((j 1 (1+ j)) (l1 l (cdr l1)))
|
||||
((>= j i)
|
||||
(setq left l)
|
||||
(setq right (cdr l1))
|
||||
(rplacd l1 nil))
|
||||
(declare (fixnum j)))
|
||||
(setq left (sort left))
|
||||
(setq right (sort right))
|
||||
(cond ((endp left) (return right))
|
||||
((endp right) (return left)))
|
||||
(setq l0 (cons nil nil))
|
||||
(setq l1 l0)
|
||||
(setq key-left (funcall key (car left)))
|
||||
(setq key-right (funcall key (car right)))
|
||||
loop
|
||||
(cond ((funcall predicate key-left key-right) (go left))
|
||||
((funcall predicate key-right key-left) (go right))
|
||||
(t (go left)))
|
||||
left
|
||||
(rplacd l1 left)
|
||||
(setq l1 (cdr l1))
|
||||
(setq left (cdr left))
|
||||
(when (endp left)
|
||||
(rplacd l1 right)
|
||||
(return (cdr l0)))
|
||||
(setq key-left (funcall key (car left)))
|
||||
(go loop)
|
||||
right
|
||||
(rplacd l1 right)
|
||||
(setq l1 (cdr l1))
|
||||
(setq right (cdr right))
|
||||
(when (endp right)
|
||||
(rplacd l1 left)
|
||||
(return (cdr l0)))
|
||||
(setq key-right (funcall key (car right)))
|
||||
(go loop))))
|
||||
(sort l)))
|
||||
|
||||
|
||||
(defun quick-sort (seq start end pred key)
|
||||
(declare (fixnum start end)
|
||||
(function pred key)
|
||||
(optimize (safety 0))
|
||||
(si::c-local))
|
||||
(unless key (setq key #'identity))
|
||||
(if (<= end (the fixnum (1+ start)))
|
||||
seq
|
||||
(let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
|
||||
|
|
@ -649,6 +672,8 @@ X and Y, if both
|
|||
(FUNCALL TEST Y X)
|
||||
evaluates to NIL, then the order of X and Y are the same as in the original
|
||||
SEQUENCE. See SORT."
|
||||
(setf key (if key (si::coerce-to-function key) #'identity)
|
||||
predicate (si::coerce-to-function predicate))
|
||||
(if (listp sequence)
|
||||
(list-merge-sort sequence predicate key)
|
||||
(if (or (stringp sequence) (bit-vector-p sequence))
|
||||
|
|
@ -667,33 +692,32 @@ sequence of TYPE. Both SEQUENCEs may be destroyed. If both SEQUENCE1 and
|
|||
SEQUENCE2 are sorted in the sense of TEST, then the result is also sorted in
|
||||
the sense of TEST."
|
||||
(declare (fixnum l1 l2))
|
||||
(unless key (setq key #'identity))
|
||||
(do ((newseq (make-sequence result-type (the fixnum (+ l1 l2))))
|
||||
(j 0 (1+ j))
|
||||
(i1 0)
|
||||
(i2 0))
|
||||
((and (= i1 l1) (= i2 l2)) newseq)
|
||||
(declare (fixnum j i1 i2))
|
||||
(cond ((and (< i1 l1) (< i2 l2))
|
||||
(cond ((funcall predicate
|
||||
(funcall key (elt sequence1 i1))
|
||||
(funcall key (elt sequence2 i2)))
|
||||
(setf (elt newseq j) (elt sequence1 i1))
|
||||
(incf i1))
|
||||
((funcall predicate
|
||||
(funcall key (elt sequence2 i2))
|
||||
(funcall key (elt sequence1 i1)))
|
||||
(setf (elt newseq j) (elt sequence2 i2))
|
||||
(incf i2))
|
||||
(t
|
||||
(setf (elt newseq j) (elt sequence1 i1))
|
||||
(incf i1))))
|
||||
((< i1 l1)
|
||||
(setf (elt newseq j) (elt sequence1 i1))
|
||||
(incf i1))
|
||||
(t
|
||||
(setf (elt newseq j) (elt sequence2 i2))
|
||||
(incf i2)))))
|
||||
(with-key (key)
|
||||
(with-predicate (predicate)
|
||||
(do* ((newseq (make-sequence result-type (the fixnum (+ l1 l2))))
|
||||
(j 0 (1+ j))
|
||||
(i1 0)
|
||||
(i2 0))
|
||||
((and (= i1 l1) (= i2 l2)) newseq)
|
||||
(declare (fixnum j i1 i2))
|
||||
(let* ((v2 (key (elt sequence2 i2)))
|
||||
(v1 (key (elt sequence1 i1))))
|
||||
(cond ((and (< i1 l1) (< i2 l2))
|
||||
(cond ((predicate v1 v2)
|
||||
(setf (elt newseq j) v1)
|
||||
(incf i1))
|
||||
((predicate v2 v1)
|
||||
(setf (elt newseq j) v2)
|
||||
(incf i2))
|
||||
(t
|
||||
(setf (elt newseq j) v1)
|
||||
(incf i1))))
|
||||
((< i1 l1)
|
||||
(setf (elt newseq j) v1)
|
||||
(incf i1))
|
||||
(t
|
||||
(setf (elt newseq j) v2)
|
||||
(incf i2))))))))
|
||||
|
||||
(defun complement (f)
|
||||
"Args: (f)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue