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

Last change on this file was 16685, checked in by rme, 5 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 6.7 KB
1;;;-*-Mode: LISP; Package: CCL -*-
3;;; Copyright 1994-2009 Clozure Associates
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
17;;; Low-level list sorting routines.  Used by CLOS and SORT.
19(in-package "CCL")
21(eval-when (:compile-toplevel :execute)
23(defmacro apply-key (key value)
24  `(if ,key
25     (funcall ,key ,value)
26     ,value))
30;; A macro to make predicate & key into lfuns, or maybe NIL.
31(defmacro canonicalize-pred-and-key (&optional (pred 'pred) (key 'key))
32  `(progn (setq ,pred (coerce-to-function ,pred))
33          (unless (null ,key)
34            (setq ,key (coerce-to-function ,key))
35            (if (eq ,key #'identity) (setq ,key nil)))))
38(defun final-cons (p)
39  (do* ((drag p lead)
40        (lead (cdr p) (cdr lead)))
41       ((null lead)
42        drag)))
44;;;                modified to return a pointer to the end of the result
45;;;                   and to not cons header each time its called.
46;;; It destructively merges list-1 with list-2.  In the resulting
47;;; list, elements of list-2 are guaranteed to come after equal elements
48;;; of list-1.
49(defun merge-lists* (list-1 list-2 pred key)
50  (declare (optimize (speed 3) (safety 0)))
51  (if (null key)
52    (merge-lists*-no-key list-1 list-2 pred) 
53    (cond ((null list-1)
54           (values list-2 (final-cons list-2)))
55          ((null list-2)
56           (values list-1 (final-cons list-1)))
57          (t (let* ((result (cons nil nil))
58                    (P result)                  ; P points to last cell of result
59                    (key-1 (apply-key key (car list-1)))
60                    (key-2 (apply-key key (car list-2))))
61               (declare (dynamic-extent result))
62               (declare (type list p))
63               (loop
64                 (cond ((funcall pred key-2 key-1)
65                        (rplacd P list-2)       ; append the lesser list to last cell of
66                        (setq P (cdr P))        ;   result.  Note: test must bo done for
67                        (pop list-2)            ;   list-2 < list-1 so merge will be
68                        (unless list-2          ;   stable for list-1
69                          (rplacd P list-1)
70                          (return (values (cdr result) (final-cons p))))
71                        (setq key-2 (apply-key key (car list-2))))
72                       (T (rplacd P list-1)         
73                          (setq P (cdr P))
74                          (pop list-1)
75                          (unless list-1
76                            (rplacd P list-2)
77                            (return (values (cdr result) (final-cons p))))
78                          (setq key-1 (apply-key key (car list-1)))))))))))
80(defun merge-lists*-no-key (list-1 list-2 pred)
81  (declare (optimize (speed 3) (safety 0)))
82  (cond ((null list-1)
83         (values list-2 (final-cons list-2)))
84        ((null list-2)
85         (values list-1 (final-cons list-1)))
86        (t (let* ((result (cons nil nil))
87                  (P result)                  ; P points to last cell of result
88                  (key-1 (car list-1))
89                  (key-2 (car list-2)))
90             (declare (dynamic-extent result))
91             (declare (type list p))
92             (loop
93               (cond ((funcall pred key-2 key-1)
94                      (rplacd P list-2)        ; append the lesser list to last cell of
95                      (setq P (cdr P))         ;   result.  Note: test must bo done for
96                      (pop list-2)             ;   list-2 < list-1 so merge will be
97                      (unless list-2           ;   stable for list-1
98                        (rplacd P list-1)
99                        (return (values (cdr result) (final-cons p))))
100                      (setq key-2 (car list-2)))
101                     (T (rplacd P list-1)
102                        (setq P (cdr P))
103                        (pop list-1)
104                        (unless list-1
105                          (rplacd P list-2)
106                          (return (values (cdr result) (final-cons p))))
107                        (setq key-1 (car list-1)))))))))
109(defun sort-list (list pred key)
110  (canonicalize-pred-and-key pred key)
111  (let ((head (cons nil list))          ; head holds on to everything
112          (n 1)                                ; bottom-up size of lists to be merged
113          unsorted                             ; unsorted is the remaining list to be
114                                        ;   broken into n size lists and merged
115          list-1                               ; list-1 is one length n list to be merged
116          last)                                ; last points to the last visited cell
117    (declare (fixnum n))
118    (declare (dynamic-extent head))
119    (loop
120      ;; start collecting runs of n at the first element
121      (setf unsorted (cdr head))
122      ;; tack on the first merge of two n-runs to the head holder
123      (setf last head)
124      (let ((n-1 (1- n)))
125        (declare (fixnum n-1))
126        (loop
127            (setf list-1 unsorted)
128            (let ((temp (nthcdr n-1 list-1))
129                  list-2)
130              (cond (temp
131                       ;; there are enough elements for a second run
132                       (setf list-2 (cdr temp))
133                       (setf (cdr temp) nil)
134                       (setf temp (nthcdr n-1 list-2))
135                       (cond (temp
136                                (setf unsorted (cdr temp))
137                                (setf (cdr temp) nil))
138                             ;; the second run goes off the end of the list
139                             (t (setf unsorted nil)))
140                       (multiple-value-bind (merged-head merged-last)
141                                            (merge-lists* list-1 list-2 pred key)
142                         (setf (cdr last) merged-head)
143                         (setf last merged-last))
144                       (if (null unsorted) (return)))
145                      ;; if there is only one run, then tack it on to the end
146                      (t (setf (cdr last) list-1)
147                         (return)))))
148        (setf n (ash n 1)) ; (+ n n)
149        ;; If the inner loop only executed once, then there were only enough
150        ;; elements for two runs given n, so all the elements have been merged
151        ;; into one list.  This may waste one outer iteration to realize.
152        (if (eq list-1 (cdr head))
153            (return list-1))))))
156;; The no-key version of %sort-list
157;; list had better be a list.
158;; pred had better be functionp.
159(defun %sort-list-no-key (list pred)
160  (sort-list list pred nil))
162(defun sort-list-error ()
163  (error "List arg to SORT not a proper list"))
Note: See TracBrowser for help on using the repository browser.