source: trunk/abcl/src/org/armedbear/lisp/remove.lisp @ 12516

Last change on this file since 12516 was 12516, checked in by astalla, 11 years ago

Support for user-extensible sequences, adapted from SBCL.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 7.1 KB
Line 
1;;; remove.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: remove.lisp 12516 2010-03-03 21:05:41Z astalla $
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;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package "SYSTEM")
33
34(require "DELETE") ; MUMBLE-DELETE-FROM-END
35(require "EXTENSIBLE-SEQUENCES-BASE")
36
37;;; From CMUCL.
38
39(defmacro real-count (count)
40  `(cond ((null ,count) most-positive-fixnum)
41         ((fixnump ,count) (if (minusp ,count) 0 ,count))
42         ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum))
43         (t ,count)))
44
45(defmacro mumble-remove-macro (bump left begin finish right pred)
46  `(do ((index ,begin (,bump index))
47        (result
48         (do ((index ,left (,bump index))
49              (result (make-sequence-like sequence length)))
50           ((= index ,begin) result)
51           (aset result index (aref sequence index))))
52        (new-index ,begin)
53        (number-zapped 0)
54        (this-element))
55     ((or (= index ,finish) (= number-zapped count))
56      (do ((index index (,bump index))
57           (new-index new-index (,bump new-index)))
58        ((= index ,right) (shrink-vector result new-index))
59        (aset result new-index (aref sequence index))))
60     (setq this-element (aref sequence index))
61     (cond (,pred (setq number-zapped (1+ number-zapped)))
62           (t (aset result new-index this-element)
63              (setq new-index (,bump new-index))))))
64
65(defmacro mumble-remove (pred)
66  `(mumble-remove-macro 1+ 0 start end length ,pred))
67
68(defmacro mumble-remove-from-end (pred)
69  `(let ((sequence (copy-seq sequence)))
70     (mumble-delete-from-end ,pred)))
71
72(defmacro normal-mumble-remove ()
73  `(mumble-remove
74    (if test-not
75        (not (funcall test-not item (apply-key key this-element)))
76        (funcall test item (apply-key key this-element)))))
77
78(defmacro normal-mumble-remove-from-end ()
79  `(mumble-remove-from-end
80    (if test-not
81        (not (funcall test-not item (apply-key key this-element)))
82        (funcall test item (apply-key key this-element)))))
83
84(defmacro if-mumble-remove ()
85  `(mumble-remove (funcall predicate (apply-key key this-element))))
86
87(defmacro if-mumble-remove-from-end ()
88  `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
89
90(defmacro if-not-mumble-remove ()
91  `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
92
93(defmacro if-not-mumble-remove-from-end ()
94  `(mumble-remove-from-end
95    (not (funcall predicate (apply-key key this-element)))))
96
97(defmacro list-remove-macro (pred reverse-p)
98  `(let* ((sequence ,(if reverse-p
99                         '(reverse sequence)
100                         'sequence))
101          (%start ,(if reverse-p '(- length end) 'start))
102          (%end ,(if reverse-p '(- length start) 'end))
103          (splice (list nil))
104          (results (do ((index 0 (1+ index))
105                        (before-start splice))
106                     ((= index %start) before-start)
107                     (setq splice
108                           (cdr (rplacd splice (list (pop sequence))))))))
109     (do ((index %start (1+ index))
110          (this-element)
111          (number-zapped 0))
112       ((or (= index %end) (= number-zapped count))
113        (do ((index index (1+ index)))
114          ((null sequence)
115           ,(if reverse-p
116                '(nreverse (cdr results))
117                '(cdr results)))
118          (setq splice (cdr (rplacd splice (list (pop sequence)))))))
119       (setq this-element (pop sequence))
120       (if ,pred
121           (setq number-zapped (1+ number-zapped))
122           (setq splice (cdr (rplacd splice (list this-element))))))))
123
124
125(defmacro list-remove (pred)
126  `(list-remove-macro ,pred nil))
127
128(defmacro list-remove-from-end (pred)
129  `(list-remove-macro ,pred t))
130
131(defmacro normal-list-remove ()
132  `(list-remove
133    (if test-not
134        (not (funcall test-not item (apply-key key this-element)))
135        (funcall test item (apply-key key this-element)))))
136
137(defmacro normal-list-remove-from-end ()
138  `(list-remove-from-end
139    (if test-not
140        (not (funcall test-not item (apply-key key this-element)))
141        (funcall test item (apply-key key this-element)))))
142
143(defmacro if-list-remove ()
144  `(list-remove
145    (funcall predicate (apply-key key this-element))))
146
147(defmacro if-list-remove-from-end ()
148  `(list-remove-from-end
149    (funcall predicate (apply-key key this-element))))
150
151(defmacro if-not-list-remove ()
152  `(list-remove
153    (not (funcall predicate (apply-key key this-element)))))
154
155(defmacro if-not-list-remove-from-end ()
156  `(list-remove-from-end
157    (not (funcall predicate (apply-key key this-element)))))
158
159(defun remove (item sequence &rest args &key from-end (test #'eql) test-not
160         (start 0) end count key)
161  (let* ((length (length sequence))
162   (end (or end length))
163   (count (real-count count)))
164    (sequence::seq-dispatch sequence
165      (if from-end
166    (normal-list-remove-from-end)
167    (normal-list-remove))
168      (if from-end
169    (normal-mumble-remove-from-end)
170    (normal-mumble-remove))
171      (apply #'sequence:remove item sequence args))))
172
173(defun remove-if (predicate sequence &rest args &key from-end (start 0)
174      end count key)
175  (let* ((length (length sequence))
176   (end (or end length))
177   (count (real-count count)))
178    (sequence::seq-dispatch sequence
179      (if from-end
180    (if-list-remove-from-end)
181    (if-list-remove))
182      (if from-end
183    (if-mumble-remove-from-end)
184    (if-mumble-remove))
185      (apply #'sequence:remove-if predicate sequence args))))
186
187(defun remove-if-not (predicate sequence &rest args &key from-end (start 0)
188          end count key)
189  (let* ((length (length sequence))
190   (end (or end length))
191   (count (real-count count)))
192    (sequence::seq-dispatch sequence
193      (if from-end
194    (if-not-list-remove-from-end)
195    (if-not-list-remove))
196      (if from-end
197    (if-not-mumble-remove-from-end)
198    (if-not-mumble-remove))
199      (apply #'sequence:remove-if-not predicate sequence args))))
Note: See TracBrowser for help on using the repository browser.