source: trunk/j/src/org/armedbear/lisp/nsubstitute.lisp @ 9266

Last change on this file since 9266 was 2730, checked in by piso, 18 years ago

(in-package "SYSTEM")

File size: 5.2 KB
Line 
1;;; nsubstitute.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: nsubstitute.lisp,v 1.5 2003-07-02 18:43:25 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;;; NSUBSTITUTE (from CMUCL)
20
21(in-package "SYSTEM")
22
23;;; From CMUCL.
24
25(defmacro real-count (count)
26  `(cond ((null ,count) most-positive-fixnum)
27         ((fixnump ,count) (if (minusp ,count) 0 ,count))
28         ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum))
29         (t ,count)))
30
31(defun nlist-substitute* (new old sequence test test-not start end count key)
32  (do ((list (nthcdr start sequence) (cdr list))
33       (index start (1+ index)))
34      ((or (= index end) (null list) (= count 0)) sequence)
35    (when (if test-not
36        (not (funcall test-not old (apply-key key (car list))))
37        (funcall test old (apply-key key (car list))))
38      (rplaca list new)
39      (setq count (1- count)))))
40
41(defun nvector-substitute* (new old sequence incrementer
42                                test test-not start end count key)
43  (do ((index start (+ index incrementer)))
44      ((or (= index end) (= count 0)) sequence)
45    (when (if test-not
46        (not (funcall test-not old (apply-key key (aref sequence index))))
47        (funcall test old (apply-key key (aref sequence index))))
48      (setf (aref sequence index) new)
49      (setq count (1- count)))))
50
51(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not
52                        end count key (start 0))
53  (let ((end (or end (length sequence)))
54  (count (real-count count)))
55    (if (listp sequence)
56  (if from-end
57      (let ((length (length sequence)))
58        (nreverse (nlist-substitute*
59       new old (nreverse sequence)
60       test test-not (- length end) (- length start) count key)))
61      (nlist-substitute* new old sequence
62             test test-not start end count key))
63  (if from-end
64      (nvector-substitute* new old sequence -1
65         test test-not (1- end) (1- start) count key)
66      (nvector-substitute* new old sequence 1
67         test test-not start end count key)))))
68
69
70(defun nlist-substitute-if* (new test sequence start end count key)
71  (do ((list (nthcdr start sequence) (cdr list))
72       (index start (1+ index)))
73      ((or (= index end) (null list) (= count 0)) sequence)
74    (when (funcall test (apply-key key (car list)))
75      (rplaca list new)
76      (setq count (1- count)))))
77
78(defun nvector-substitute-if* (new test sequence incrementer
79                                   start end count key)
80  (do ((index start (+ index incrementer)))
81      ((or (= index end) (= count 0)) sequence)
82    (when (funcall test (apply-key key (aref sequence index)))
83      (setf (aref sequence index) new)
84      (setq count (1- count)))))
85
86(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key)
87  (let ((end (or end (length sequence)))
88  (count (real-count count)))
89    (if (listp sequence)
90  (if from-end
91      (let ((length (length sequence)))
92        (nreverse (nlist-substitute-if*
93       new test (nreverse sequence)
94       (- length end) (- length start) count key)))
95      (nlist-substitute-if* new test sequence
96          start end count key))
97  (if from-end
98      (nvector-substitute-if* new test sequence -1
99            (1- end) (1- start) count key)
100      (nvector-substitute-if* new test sequence 1
101            start end count key)))))
102
103
104(defun nlist-substitute-if-not* (new test sequence start end count key)
105  (do ((list (nthcdr start sequence) (cdr list))
106       (index start (1+ index)))
107      ((or (= index end) (null list) (= count 0)) sequence)
108    (when (not (funcall test (apply-key key (car list))))
109      (rplaca list new)
110      (setq count (1- count)))))
111
112(defun nvector-substitute-if-not* (new test sequence incrementer
113                                       start end count key)
114  (do ((index start (+ index incrementer)))
115      ((or (= index end) (= count 0)) sequence)
116    (when (not (funcall test (apply-key key (aref sequence index))))
117      (setf (aref sequence index) new)
118      (setq count (1- count)))))
119
120(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
121             end count key)
122  (let ((end (or end (length sequence)))
123  (count (real-count count)))
124    (if (listp sequence)
125  (if from-end
126      (let ((length (length sequence)))
127        (nreverse (nlist-substitute-if-not*
128       new test (nreverse sequence)
129       (- length end) (- length start) count key)))
130      (nlist-substitute-if-not* new test sequence
131              start end count key))
132  (if from-end
133      (nvector-substitute-if-not* new test sequence -1
134          (1- end) (1- start) count key)
135      (nvector-substitute-if-not* new test sequence 1
136          start end count key)))))
Note: See TracBrowser for help on using the repository browser.