[6] | 1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
| 2 | ;;; |
---|
[13067] | 3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
[6] | 4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
[13066] | 5 | ;;; This file is part of Clozure CL. |
---|
[6] | 6 | ;;; |
---|
[13066] | 7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
| 8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
[6] | 9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
[13066] | 10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
[6] | 11 | ;;; conflict, the preamble takes precedence. |
---|
| 12 | ;;; |
---|
[13066] | 13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
[6] | 14 | ;;; |
---|
| 15 | ;;; The LLGPL is also available online at |
---|
| 16 | ;;; http://opensource.franz.com/preamble.html |
---|
| 17 | |
---|
| 18 | ;;; Low-level list sorting routines. Used by CLOS and SORT. |
---|
| 19 | |
---|
[2326] | 20 | (in-package "CCL") |
---|
| 21 | |
---|
[6] | 22 | (eval-when (:compile-toplevel :execute) |
---|
| 23 | |
---|
| 24 | (defmacro apply-key (key value) |
---|
| 25 | `(if ,key |
---|
| 26 | (funcall ,key ,value) |
---|
| 27 | ,value)) |
---|
| 28 | |
---|
| 29 | ) |
---|
| 30 | |
---|
| 31 | ;; A macro to make predicate & key into lfuns, or maybe NIL. |
---|
| 32 | (defmacro canonicalize-pred-and-key (&optional (pred 'pred) (key 'key)) |
---|
| 33 | `(progn (setq ,pred (coerce-to-function ,pred)) |
---|
| 34 | (unless (null ,key) |
---|
| 35 | (setq ,key (coerce-to-function ,key)) |
---|
| 36 | (if (eq ,key #'identity) (setq ,key nil))))) |
---|
| 37 | |
---|
| 38 | |
---|
| 39 | (defun final-cons (p) |
---|
| 40 | (do* ((drag p lead) |
---|
| 41 | (lead (cdr p) (cdr lead))) |
---|
| 42 | ((null lead) |
---|
| 43 | drag))) |
---|
| 44 | |
---|
| 45 | ;;; modified to return a pointer to the end of the result |
---|
| 46 | ;;; and to not cons header each time its called. |
---|
| 47 | ;;; It destructively merges list-1 with list-2. In the resulting |
---|
| 48 | ;;; list, elements of list-2 are guaranteed to come after equal elements |
---|
| 49 | ;;; of list-1. |
---|
| 50 | (defun merge-lists* (list-1 list-2 pred key) |
---|
| 51 | (declare (optimize (speed 3) (safety 0))) |
---|
| 52 | (if (null key) |
---|
| 53 | (merge-lists*-no-key list-1 list-2 pred) |
---|
| 54 | (cond ((null list-1) |
---|
| 55 | (values list-2 (final-cons list-2))) |
---|
| 56 | ((null list-2) |
---|
| 57 | (values list-1 (final-cons list-1))) |
---|
| 58 | (t (let* ((result (cons nil nil)) |
---|
| 59 | (P result) ; P points to last cell of result |
---|
| 60 | (key-1 (apply-key key (car list-1))) |
---|
| 61 | (key-2 (apply-key key (car list-2)))) |
---|
| 62 | (declare (dynamic-extent result)) |
---|
| 63 | (declare (type list p)) |
---|
| 64 | (loop |
---|
| 65 | (cond ((funcall pred key-2 key-1) |
---|
| 66 | (rplacd P list-2) ; append the lesser list to last cell of |
---|
| 67 | (setq P (cdr P)) ; result. Note: test must bo done for |
---|
| 68 | (pop list-2) ; list-2 < list-1 so merge will be |
---|
| 69 | (unless list-2 ; stable for list-1 |
---|
| 70 | (rplacd P list-1) |
---|
| 71 | (return (values (cdr result) (final-cons p)))) |
---|
| 72 | (setq key-2 (apply-key key (car list-2)))) |
---|
| 73 | (T (rplacd P list-1) |
---|
| 74 | (setq P (cdr P)) |
---|
| 75 | (pop list-1) |
---|
| 76 | (unless list-1 |
---|
| 77 | (rplacd P list-2) |
---|
| 78 | (return (values (cdr result) (final-cons p)))) |
---|
| 79 | (setq key-1 (apply-key key (car list-1))))))))))) |
---|
| 80 | |
---|
| 81 | (defun merge-lists*-no-key (list-1 list-2 pred) |
---|
| 82 | (declare (optimize (speed 3) (safety 0))) |
---|
| 83 | (cond ((null list-1) |
---|
| 84 | (values list-2 (final-cons list-2))) |
---|
| 85 | ((null list-2) |
---|
| 86 | (values list-1 (final-cons list-1))) |
---|
| 87 | (t (let* ((result (cons nil nil)) |
---|
| 88 | (P result) ; P points to last cell of result |
---|
| 89 | (key-1 (car list-1)) |
---|
| 90 | (key-2 (car list-2))) |
---|
| 91 | (declare (dynamic-extent result)) |
---|
| 92 | (declare (type list p)) |
---|
| 93 | (loop |
---|
| 94 | (cond ((funcall pred key-2 key-1) |
---|
| 95 | (rplacd P list-2) ; append the lesser list to last cell of |
---|
| 96 | (setq P (cdr P)) ; result. Note: test must bo done for |
---|
| 97 | (pop list-2) ; list-2 < list-1 so merge will be |
---|
| 98 | (unless list-2 ; stable for list-1 |
---|
| 99 | (rplacd P list-1) |
---|
| 100 | (return (values (cdr result) (final-cons p)))) |
---|
| 101 | (setq key-2 (car list-2))) |
---|
| 102 | (T (rplacd P list-1) |
---|
| 103 | (setq P (cdr P)) |
---|
| 104 | (pop list-1) |
---|
| 105 | (unless list-1 |
---|
| 106 | (rplacd P list-2) |
---|
| 107 | (return (values (cdr result) (final-cons p)))) |
---|
| 108 | (setq key-1 (car list-1))))))))) |
---|
| 109 | |
---|
| 110 | (defun sort-list (list pred key) |
---|
| 111 | (canonicalize-pred-and-key pred key) |
---|
| 112 | (let ((head (cons nil list)) ; head holds on to everything |
---|
| 113 | (n 1) ; bottom-up size of lists to be merged |
---|
| 114 | unsorted ; unsorted is the remaining list to be |
---|
| 115 | ; broken into n size lists and merged |
---|
| 116 | list-1 ; list-1 is one length n list to be merged |
---|
| 117 | last) ; last points to the last visited cell |
---|
| 118 | (declare (fixnum n)) |
---|
| 119 | (declare (dynamic-extent head)) |
---|
| 120 | (loop |
---|
| 121 | ;; start collecting runs of n at the first element |
---|
| 122 | (setf unsorted (cdr head)) |
---|
| 123 | ;; tack on the first merge of two n-runs to the head holder |
---|
| 124 | (setf last head) |
---|
| 125 | (let ((n-1 (1- n))) |
---|
| 126 | (declare (fixnum n-1)) |
---|
| 127 | (loop |
---|
| 128 | (setf list-1 unsorted) |
---|
| 129 | (let ((temp (nthcdr n-1 list-1)) |
---|
| 130 | list-2) |
---|
| 131 | (cond (temp |
---|
| 132 | ;; there are enough elements for a second run |
---|
| 133 | (setf list-2 (cdr temp)) |
---|
| 134 | (setf (cdr temp) nil) |
---|
| 135 | (setf temp (nthcdr n-1 list-2)) |
---|
| 136 | (cond (temp |
---|
| 137 | (setf unsorted (cdr temp)) |
---|
| 138 | (setf (cdr temp) nil)) |
---|
| 139 | ;; the second run goes off the end of the list |
---|
| 140 | (t (setf unsorted nil))) |
---|
| 141 | (multiple-value-bind (merged-head merged-last) |
---|
| 142 | (merge-lists* list-1 list-2 pred key) |
---|
| 143 | (setf (cdr last) merged-head) |
---|
| 144 | (setf last merged-last)) |
---|
| 145 | (if (null unsorted) (return))) |
---|
| 146 | ;; if there is only one run, then tack it on to the end |
---|
| 147 | (t (setf (cdr last) list-1) |
---|
| 148 | (return))))) |
---|
| 149 | (setf n (ash n 1)) ; (+ n n) |
---|
| 150 | ;; If the inner loop only executed once, then there were only enough |
---|
| 151 | ;; elements for two runs given n, so all the elements have been merged |
---|
| 152 | ;; into one list. This may waste one outer iteration to realize. |
---|
| 153 | (if (eq list-1 (cdr head)) |
---|
| 154 | (return list-1)))))) |
---|
| 155 | |
---|
| 156 | |
---|
| 157 | ;; The no-key version of %sort-list |
---|
| 158 | ;; list had better be a list. |
---|
| 159 | ;; pred had better be functionp. |
---|
| 160 | (defun %sort-list-no-key (list pred) |
---|
| 161 | (sort-list list pred nil)) |
---|
| 162 | |
---|
| 163 | (defun sort-list-error () |
---|
| 164 | (error "List arg to SORT not a proper list")) |
---|
| 165 | |
---|
| 166 | |
---|
| 167 | |
---|