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

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

Got rid of exports from SYSTEM package.

File size: 5.1 KB
Line 
1;;; substitute.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: substitute.lisp,v 1.7 2003-08-25 18:22:58 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
21(in-package "COMMON-LISP")
22
23(export '(substitute substitute-if substitute-if-not))
24
25;;; From CMUCL.
26
27(defmacro real-count (count)
28  `(cond ((null ,count) most-positive-fixnum)
29         ((sys::fixnump ,count) (if (minusp ,count) 0 ,count))
30         ((integerp ,count) (if (minusp ,count) 0 most-positive-fixnum))
31         (t ,count)))
32
33(defun list-substitute* (pred new list start end count key test test-not old)
34  (let* ((result (list nil))
35   elt
36   (splice result)
37   (list list))           ; Get a local list for a stepper.
38    (do ((index 0 (1+ index)))
39      ((= index start))
40      (setq splice (cdr (rplacd splice (list (car list)))))
41      (setq list (cdr list)))
42    (do ((index start (1+ index)))
43      ((or (= index end) (null list) (= count 0)))
44      (setq elt (car list))
45      (setq splice
46      (cdr (rplacd splice
47       (list
48        (cond
49         ((case pred
50                              (normal
51                               (if test-not
52                                   (not
53                                    (funcall test-not old (sys::apply-key key elt)))
54                                   (funcall test old (sys::apply-key key elt))))
55                              (if (funcall test (sys::apply-key key elt)))
56                              (if-not (not (funcall test (sys::apply-key key elt)))))
57          (setq count (1- count))
58          new)
59                           (t elt))))))
60      (setq list (cdr list)))
61    (do ()
62      ((null list))
63      (setq splice (cdr (rplacd splice (list (car list)))))
64      (setq list (cdr list)))
65    (cdr result)))
66
67
68;;; Replace old with new in sequence moving from left to right by incrementer
69;;; on each pass through the loop. Called by all three substitute functions.
70(defun vector-substitute* (pred new sequence incrementer left right length
71                                start end count key test test-not old)
72  (let ((result (sys::make-sequence-like sequence length))
73  (index left))
74    (do ()
75      ((= index start))
76      (setf (aref result index) (aref sequence index))
77      (setq index (+ index incrementer)))
78    (do ((elt))
79      ((or (= index end) (= count 0)))
80      (setq elt (aref sequence index))
81      (setf (aref result index)
82      (cond ((case pred
83                     (normal
84                      (if test-not
85                          (not (funcall test-not old (sys::apply-key key elt)))
86                          (funcall test old (sys::apply-key key elt))))
87                     (if (funcall test (sys::apply-key key elt)))
88                     (if-not (not (funcall test (sys::apply-key key elt)))))
89       (setq count (1- count))
90       new)
91      (t elt)))
92      (setq index (+ index incrementer)))
93    (do ()
94      ((= index right))
95      (setf (aref result index) (aref sequence index))
96      (setq index (+ index incrementer)))
97    result))
98
99(defmacro subst-dispatch (pred)
100  `(if (listp sequence)
101       (if from-end
102           (nreverse (list-substitute* ,pred new (reverse sequence)
103                                       (- length end)
104                                       (- length start)
105                                       count key test test-not old))
106           (list-substitute* ,pred new sequence start end count key test test-not
107                             old))
108       (if from-end
109           (vector-substitute* ,pred new sequence -1 (1- length)
110                               -1 length (1- end)
111                               (1- start) count key test test-not old)
112           (vector-substitute* ,pred new sequence 1 0 length length
113                               start end count key test test-not old))))
114
115
116(defun substitute (new old sequence &key from-end (test #'eql) test-not
117                       (start 0) count end key)
118  (let* ((length (length sequence))
119   (end (or end length))
120   (count (real-count count)))
121    (subst-dispatch 'normal)))
122
123
124(defun substitute-if (new test sequence &key from-end (start 0) end count key)
125  (let* ((length (length sequence))
126   (end (or end length))
127   (count (real-count count))
128   test-not
129   old)
130    (subst-dispatch 'if)))
131
132
133(defun substitute-if-not (new test sequence &key from-end (start 0)
134                              end count key)
135  (let* ((length (length sequence))
136   (end (or end length))
137   (count (real-count count))
138   test-not
139   old)
140    (subst-dispatch 'if-not)))
Note: See TracBrowser for help on using the repository browser.