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