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

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

MUMBLE-REMOVE-MACRO: use %VSET.

File size: 6.3 KB
Line 
1;;; remove.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: remove.lisp,v 1.5 2003-10-08 17:48:47 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(resolve 'delete) ; MUMBLE-DELETE-FROM-END
23
24;;; From CMUCL.
25
26(defmacro real-count (count)
27  `(cond ((null ,count) most-positive-fixnum)
28         ((fixnump ,count) (if (minusp ,count) 0 ,count))
29         ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum))
30         (t ,count)))
31
32(defmacro mumble-remove-macro (bump left begin finish right pred)
33  `(do ((index ,begin (,bump index))
34        (result
35         (do ((index ,left (,bump index))
36              (result (make-sequence-like sequence length)))
37           ((= index ,begin) result)
38           (%vset result index (aref sequence index))))
39        (new-index ,begin)
40        (number-zapped 0)
41        (this-element))
42     ((or (= index ,finish) (= number-zapped count))
43      (do ((index index (,bump index))
44           (new-index new-index (,bump new-index)))
45        ((= index ,right) (shrink-vector result new-index))
46        (%vset result new-index (aref sequence index))))
47     (setq this-element (aref sequence index))
48     (cond (,pred (setq number-zapped (1+ number-zapped)))
49           (t (%vset result new-index this-element)
50              (setq new-index (,bump new-index))))))
51
52(defmacro mumble-remove (pred)
53  `(mumble-remove-macro 1+ 0 start end length ,pred))
54
55(defmacro mumble-remove-from-end (pred)
56  `(let ((sequence (copy-seq sequence)))
57     (mumble-delete-from-end ,pred)))
58
59(defmacro normal-mumble-remove ()
60  `(mumble-remove
61    (if test-not
62        (not (funcall test-not item (apply-key key this-element)))
63        (funcall test item (apply-key key this-element)))))
64
65(defmacro normal-mumble-remove-from-end ()
66  `(mumble-remove-from-end
67    (if test-not
68        (not (funcall test-not item (apply-key key this-element)))
69        (funcall test item (apply-key key this-element)))))
70
71(defmacro if-mumble-remove ()
72  `(mumble-remove (funcall predicate (apply-key key this-element))))
73
74(defmacro if-mumble-remove-from-end ()
75  `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
76
77(defmacro if-not-mumble-remove ()
78  `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
79
80(defmacro if-not-mumble-remove-from-end ()
81  `(mumble-remove-from-end
82    (not (funcall predicate (apply-key key this-element)))))
83
84(defmacro list-remove-macro (pred reverse-p)
85  `(let* ((sequence ,(if reverse-p
86                         '(reverse sequence)
87                         'sequence))
88          (%start ,(if reverse-p '(- length end) 'start))
89          (%end ,(if reverse-p '(- length start) 'end))
90          (splice (list nil))
91          (results (do ((index 0 (1+ index))
92                        (before-start splice))
93                     ((= index %start) before-start)
94                     (setq splice
95                           (cdr (rplacd splice (list (pop sequence))))))))
96     (do ((index %start (1+ index))
97          (this-element)
98          (number-zapped 0))
99       ((or (= index %end) (= number-zapped count))
100        (do ((index index (1+ index)))
101          ((null sequence)
102           ,(if reverse-p
103                '(nreverse (cdr results))
104                '(cdr results)))
105          (setq splice (cdr (rplacd splice (list (pop sequence)))))))
106       (setq this-element (pop sequence))
107       (if ,pred
108           (setq number-zapped (1+ number-zapped))
109           (setq splice (cdr (rplacd splice (list this-element))))))))
110
111
112(defmacro list-remove (pred)
113  `(list-remove-macro ,pred nil))
114
115(defmacro list-remove-from-end (pred)
116  `(list-remove-macro ,pred t))
117
118(defmacro normal-list-remove ()
119  `(list-remove
120    (if test-not
121        (not (funcall test-not item (apply-key key this-element)))
122        (funcall test item (apply-key key this-element)))))
123
124(defmacro normal-list-remove-from-end ()
125  `(list-remove-from-end
126    (if test-not
127        (not (funcall test-not item (apply-key key this-element)))
128        (funcall test item (apply-key key this-element)))))
129
130(defmacro if-list-remove ()
131  `(list-remove
132    (funcall predicate (apply-key key this-element))))
133
134(defmacro if-list-remove-from-end ()
135  `(list-remove-from-end
136    (funcall predicate (apply-key key this-element))))
137
138(defmacro if-not-list-remove ()
139  `(list-remove
140    (not (funcall predicate (apply-key key this-element)))))
141
142(defmacro if-not-list-remove-from-end ()
143  `(list-remove-from-end
144    (not (funcall predicate (apply-key key this-element)))))
145
146(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
147                    end count key)
148  (let* ((length (length sequence))
149   (end (or end length))
150   (count (real-count count)))
151    (if (listp sequence)
152        (if from-end
153            (normal-list-remove-from-end)
154            (normal-list-remove))
155        (if from-end
156            (normal-mumble-remove-from-end)
157            (normal-mumble-remove)))))
158
159(defun remove-if (predicate sequence &key from-end (start 0) end count key)
160  (let* ((length (length sequence))
161   (end (or end length))
162   (count (real-count count)))
163    (if (listp sequence)
164        (if from-end
165            (if-list-remove-from-end)
166            (if-list-remove))
167        (if from-end
168            (if-mumble-remove-from-end)
169            (if-mumble-remove)))))
170
171(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
172  (let* ((length (length sequence))
173   (end (or end length))
174   (count (real-count count)))
175    (if (listp sequence)
176        (if from-end
177            (if-not-list-remove-from-end)
178            (if-not-list-remove))
179        (if from-end
180            (if-not-mumble-remove-from-end)
181            (if-not-mumble-remove)))))
Note: See TracBrowser for help on using the repository browser.