source: trunk/source/level-1/l1-sort.lisp @ 15232

Last change on this file since 15232 was 13067, checked in by rme, 10 years ago

Update copyright notices.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
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
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
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
20(in-package "CCL")
21
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
Note: See TracBrowser for help on using the repository browser.