source: trunk/j/src/org/armedbear/lisp/delete.lisp @ 4256

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

Use %VSET.

File size: 6.7 KB
Line 
1;;; delete.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: delete.lisp,v 1.6 2003-10-08 17:49:55 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-delete (pred)
31  `(do ((index start (1+ index))
32        (jndex start)
33        (number-zapped 0))
34     ((or (= index end) (= number-zapped count))
35      (do ((index index (1+ index))   ; copy the rest of the vector
36           (jndex jndex (1+ jndex)))
37        ((= index length)
38         (shrink-vector sequence jndex))
39        (%vset sequence jndex (aref sequence index))))
40     (%vset sequence jndex (aref sequence index))
41     (if ,pred
42         (setq number-zapped (1+ number-zapped))
43         (setq jndex (1+ jndex)))))
44
45(defmacro mumble-delete-from-end (pred)
46  `(do ((index (1- end) (1- index)) ; find the losers
47        (number-zapped 0)
48        (losers ())
49        this-element
50        (terminus (1- start)))
51     ((or (= index terminus) (= number-zapped count))
52      (do ((losers losers)       ; delete the losers
53           (index start (1+ index))
54           (jndex start))
55        ((or (null losers) (= index end))
56         (do ((index index (1+ index))   ; copy the rest of the vector
57              (jndex jndex (1+ jndex)))
58           ((= index length)
59            (shrink-vector sequence jndex))
60           (%vset sequence jndex (aref sequence index))))
61        (%vset sequence jndex (aref sequence index))
62        (if (= index (car losers))
63            (pop losers)
64            (setq jndex (1+ jndex)))))
65     (setq this-element (aref sequence index))
66     (when ,pred
67       (setq number-zapped (1+ number-zapped))
68       (push index losers))))
69
70(defmacro normal-mumble-delete ()
71  `(mumble-delete
72    (if test-not
73        (not (funcall test-not item (funcall-key key (aref sequence index))))
74        (funcall test item (funcall-key key (aref sequence index))))))
75
76(defmacro normal-mumble-delete-from-end ()
77  `(mumble-delete-from-end
78    (if test-not
79        (not (funcall test-not item (funcall-key key this-element)))
80        (funcall test item (funcall-key key this-element)))))
81
82(defmacro list-delete (pred)
83  `(let ((handle (cons nil sequence)))
84     (do ((current (nthcdr start sequence) (cdr current))
85          (previous (nthcdr start handle))
86          (index start (1+ index))
87          (number-zapped 0))
88       ((or (= index end) (= number-zapped count))
89        (cdr handle))
90       (cond (,pred
91              (rplacd previous (cdr current))
92              (setq number-zapped (1+ number-zapped)))
93             (t
94              (setq previous (cdr previous)))))))
95
96(defmacro list-delete-from-end (pred)
97  `(let* ((reverse (nreverse sequence))
98          (handle (cons nil reverse)))
99     (do ((current (nthcdr (- length end) reverse)
100                   (cdr current))
101          (previous (nthcdr (- length end) handle))
102          (index start (1+ index))
103          (number-zapped 0))
104       ((or (= index end) (= number-zapped count))
105        (nreverse (cdr handle)))
106       (cond (,pred
107              (rplacd previous (cdr current))
108              (setq number-zapped (1+ number-zapped)))
109             (t
110              (setq previous (cdr previous)))))))
111
112(defmacro normal-list-delete ()
113  '(list-delete
114    (if test-not
115        (not (funcall test-not item (funcall-key key (car current))))
116        (funcall test item (funcall-key key (car current))))))
117
118(defmacro normal-list-delete-from-end ()
119  '(list-delete-from-end
120    (if test-not
121        (not (funcall test-not item (funcall-key key (car current))))
122        (funcall test item (funcall-key key (car current))))))
123
124(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
125                    end count key)
126  (when key
127    (setq key (coerce-to-function key)))
128  (let* ((length (length sequence))
129   (end (or end length))
130   (count (real-count count)))
131    (if (listp sequence)
132        (if from-end
133            (normal-list-delete-from-end)
134            (normal-list-delete))
135        (if from-end
136            (normal-mumble-delete-from-end)
137            (normal-mumble-delete)))))
138
139(defmacro if-mumble-delete ()
140  `(mumble-delete
141    (funcall predicate (funcall-key key (aref sequence index)))))
142
143(defmacro if-mumble-delete-from-end ()
144  `(mumble-delete-from-end
145    (funcall predicate (funcall-key key this-element))))
146
147(defmacro if-list-delete ()
148  '(list-delete
149    (funcall predicate (funcall-key key (car current)))))
150
151(defmacro if-list-delete-from-end ()
152  '(list-delete-from-end
153    (funcall predicate (funcall-key key (car current)))))
154
155(defun delete-if (predicate sequence &key from-end (start 0) key end count)
156  (when key
157    (setq key (coerce-to-function 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-delete-from-end)
164            (if-list-delete))
165        (if from-end
166            (if-mumble-delete-from-end)
167            (if-mumble-delete)))))
168
169(defmacro if-not-mumble-delete ()
170  `(mumble-delete
171    (not (funcall predicate (funcall-key key (aref sequence index))))))
172
173(defmacro if-not-mumble-delete-from-end ()
174  `(mumble-delete-from-end
175    (not (funcall predicate (funcall-key key this-element)))))
176
177(defmacro if-not-list-delete ()
178  '(list-delete
179    (not (funcall predicate (funcall-key key (car current))))))
180
181(defmacro if-not-list-delete-from-end ()
182  '(list-delete-from-end
183    (not (funcall predicate (funcall-key key (car current))))))
184
185(defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
186  (when key
187    (setq key (coerce-to-function key)))
188  (let* ((length (length sequence))
189   (end (or end length))
190   (count (real-count count)))
191    (if (listp sequence)
192        (if from-end
193            (if-not-list-delete-from-end)
194            (if-not-list-delete))
195        (if from-end
196            (if-not-mumble-delete-from-end)
197            (if-not-mumble-delete)))))
Note: See TracBrowser for help on using the repository browser.