mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 21:32:49 -08:00
Code Issues Projects Releases Packages Wiki Activity

Remove unneeded level of nesting in LIST-MERGE-SORT. MERGE uses now fast function calls and saves a couple of calls to KEY and ELT.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-02-16 16:56:29 +01:00
parent 1e7935ea46
commit f927dbd2f8
1 changed files with 93 additions and 93 deletions
Download patch file Download diff file Expand all files Collapse all files

186
src/lsp/seqlib.lsp
View file

@ -94,30 +94,31 @@
(start 0)
end
key (initial-value nil ivsp))
(with-start-end start end sequence
(with-key (key)
(cond ((not from-end)
(when (null ivsp)
(when (>= start end)
(return-from reduce (funcall function)))
(setq initial-value (key (elt sequence start)))
(incf start))
(do ((x initial-value
(funcall function x
(prog1 (key (elt sequence start))
(incf start)))))
((>= start end) x)))
(t
(when (null ivsp)
(let ((function (si::coerce-to-function function)))
(with-start-end start end sequence
(with-key (key)
(cond ((not from-end)
(when (null ivsp)
(when (>= start end)
(return-from reduce (funcall function)))
(setq initial-value (key (elt sequence start)))
(incf start))
(do ((x initial-value
(funcall function x
(prog1 (key (elt sequence start))
(incf start)))))
((>= start end) x)))
(t
(when (null ivsp)
(when (>= start end)
(return-from reduce (funcall function)))
(return-from reduce (funcall function)))
(decf end)
(setq initial-value (elt sequence end)))
(do ((x initial-value (funcall function
(key (elt sequence end))
x)))
((>= start end) x)
(decf end)))))))
(do ((x initial-value (funcall function
(key (elt sequence end))
x)))
((>= start end) x)
(decf end))))))))
(defun fill (sequence item &key (start 0) end)
(with-start-end start end sequence
@ -583,57 +584,54 @@ evaluates to NIL. See STABLE-SORT."
(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)))
(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 (list-merge-sort left predicate key))
(setq right (list-merge-sort right predicate key))
(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)))
(defun quick-sort (seq start end pred key)
@ -694,30 +692,32 @@ the sense of TEST."
(declare (fixnum l1 l2))
(with-key (key)
(with-predicate (predicate)
(do* ((newseq (make-sequence result-type (the fixnum (+ l1 l2))))
(do* ((size (the fixnum (+ l1 l2)))
(j 0 (1+ j))
(newseq (make-sequence result-type size))
(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))))))))
((= j size) newseq)
(declare (fixnum size j i1 i2))
(if (>= i1 l1)
(setf (elt newseq j) (elt sequence2 i2)
i2 (1+ i2))
(let ((v1 (elt sequence1 i1)))
(if (>= i2 l2)
(setf (elt newseq j) v1
i1 (1+ i1))
(let* ((v2 (elt sequence2 i2))
(k2 (key v2))
(k1 (key v1)))
(cond ((predicate k1 k2)
(setf (elt newseq j) v1
i1 (1+ i1)))
((predicate k2 k1)
(setf (elt newseq j) v2
i2 (1+ i2)))
(t
(setf (elt newseq j) v1
i1 (1+ i1))))))))))))
(defun complement (f)
"Args: (f)