source: trunk/j/src/org/armedbear/lisp/remove.lisp @ 2728

Last change on this file since 2728 was 2728, checked in by piso, 19 years ago

(in-package "SYSTEM")

File size: 6.2 KB
Line 
1;;; remove.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: remove.lisp,v 1.4 2003-07-02 18:24:27 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "SYSTEM")
21
22;;; From CMUCL.
23
24(defmacro real-count (count)
25  `(cond ((null ,count) most-positive-fixnum)
26         ((fixnump ,count) (if (minusp ,count) 0 ,count))
27         ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum))
28         (t ,count)))
29
30(defmacro mumble-remove-macro (bump left begin finish right pred)
31  `(do ((index ,begin (,bump index))
32        (result
33         (do ((index ,left (,bump index))
34              (result (make-sequence-like sequence length)))
35           ((= index ,begin) result)
36           (setf (aref result index) (aref sequence index))))
37        (new-index ,begin)
38        (number-zapped 0)
39        (this-element))
40     ((or (= index ,finish) (= number-zapped count))
41      (do ((index index (,bump index))
42           (new-index new-index (,bump new-index)))
43        ((= index ,right) (shrink-vector result new-index))
44        (setf (aref result new-index) (aref sequence index))))
45     (setq this-element (aref sequence index))
46     (cond (,pred (setq number-zapped (1+ number-zapped)))
47           (t (setf (aref result new-index) this-element)
48              (setq new-index (,bump new-index))))))
49
50(defmacro mumble-remove (pred)
51  `(mumble-remove-macro 1+ 0 start end length ,pred))
52
53(defmacro mumble-remove-from-end (pred)
54  `(let ((sequence (copy-seq sequence)))
55     (mumble-delete-from-end ,pred)))
56
57(defmacro normal-mumble-remove ()
58  `(mumble-remove
59    (if test-not
60        (not (funcall test-not item (apply-key key this-element)))
61        (funcall test item (apply-key key this-element)))))
62
63(defmacro normal-mumble-remove-from-end ()
64  `(mumble-remove-from-end
65    (if test-not
66        (not (funcall test-not item (apply-key key this-element)))
67        (funcall test item (apply-key key this-element)))))
68
69(defmacro if-mumble-remove ()
70  `(mumble-remove (funcall predicate (apply-key key this-element))))
71
72(defmacro if-mumble-remove-from-end ()
73  `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
74
75(defmacro if-not-mumble-remove ()
76  `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
77
78(defmacro if-not-mumble-remove-from-end ()
79  `(mumble-remove-from-end
80    (not (funcall predicate (apply-key key this-element)))))
81
82(defmacro list-remove-macro (pred reverse-p)
83  `(let* ((sequence ,(if reverse-p
84                         '(reverse sequence)
85                         'sequence))
86          (%start ,(if reverse-p '(- length end) 'start))
87          (%end ,(if reverse-p '(- length start) 'end))
88          (splice (list nil))
89          (results (do ((index 0 (1+ index))
90                        (before-start splice))
91                     ((= index %start) before-start)
92                     (setq splice
93                           (cdr (rplacd splice (list (pop sequence))))))))
94     (do ((index %start (1+ index))
95          (this-element)
96          (number-zapped 0))
97       ((or (= index %end) (= number-zapped count))
98        (do ((index index (1+ index)))
99          ((null sequence)
100           ,(if reverse-p
101                '(nreverse (cdr results))
102                '(cdr results)))
103          (setq splice (cdr (rplacd splice (list (pop sequence)))))))
104       (setq this-element (pop sequence))
105       (if ,pred
106           (setq number-zapped (1+ number-zapped))
107           (setq splice (cdr (rplacd splice (list this-element))))))))
108
109
110(defmacro list-remove (pred)
111  `(list-remove-macro ,pred nil))
112
113(defmacro list-remove-from-end (pred)
114  `(list-remove-macro ,pred t))
115
116(defmacro normal-list-remove ()
117  `(list-remove
118    (if test-not
119        (not (funcall test-not item (apply-key key this-element)))
120        (funcall test item (apply-key key this-element)))))
121
122(defmacro normal-list-remove-from-end ()
123  `(list-remove-from-end
124    (if test-not
125        (not (funcall test-not item (apply-key key this-element)))
126        (funcall test item (apply-key key this-element)))))
127
128(defmacro if-list-remove ()
129  `(list-remove
130    (funcall predicate (apply-key key this-element))))
131
132(defmacro if-list-remove-from-end ()
133  `(list-remove-from-end
134    (funcall predicate (apply-key key this-element))))
135
136(defmacro if-not-list-remove ()
137  `(list-remove
138    (not (funcall predicate (apply-key key this-element)))))
139
140(defmacro if-not-list-remove-from-end ()
141  `(list-remove-from-end
142    (not (funcall predicate (apply-key key this-element)))))
143
144(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
145                    end count key)
146  (let* ((length (length sequence))
147   (end (or end length))
148   (count (real-count count)))
149    (if (listp sequence)
150        (if from-end
151            (normal-list-remove-from-end)
152            (normal-list-remove))
153        (if from-end
154            (normal-mumble-remove-from-end)
155            (normal-mumble-remove)))))
156
157(defun remove-if (predicate sequence &key from-end (start 0) end count key)
158  (let* ((length (length sequence))
159   (end (or end length))
160   (count (real-count count)))
161    (if (listp sequence)
162        (if from-end
163            (if-list-remove-from-end)
164            (if-list-remove))
165        (if from-end
166            (if-mumble-remove-from-end)
167            (if-mumble-remove)))))
168
169(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
170  (let* ((length (length sequence))
171   (end (or end length))
172   (count (real-count count)))
173    (if (listp sequence)
174        (if from-end
175            (if-not-list-remove-from-end)
176            (if-not-list-remove))
177        (if from-end
178            (if-not-mumble-remove-from-end)
179            (if-not-mumble-remove)))))
Note: See TracBrowser for help on using the repository browser.