org.armedbear.lisp.replace.lisp Maven / Gradle / Ivy
;;; replace.lisp
;;;
;;; Copyright (C) 2003-2005 Peter Graves
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
;;; Adapted from CMUCL.
(in-package #:system)
(require "EXTENSIBLE-SEQUENCES-BASE")
#|(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro seq-dispatch (sequence list-form array-form)
`(if (listp ,sequence)
,list-form
,array-form)))|#
(eval-when (:compile-toplevel :execute)
;;; If we are copying around in the same vector, be careful not to copy the
;;; same elements over repeatedly. We do this by copying backwards.
(defmacro mumble-replace-from-mumble ()
`(if (and (eq target-sequence source-sequence) (> target-start source-start))
(let ((nelts (min (- target-end target-start) (- source-end source-start))))
(do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
(1- target-index))
(source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
(1- source-index)))
((= target-index (the fixnum (1- target-start))) target-sequence)
(declare (fixnum target-index source-index))
(setf (aref target-sequence target-index)
(aref source-sequence source-index))))
(do ((target-index target-start (1+ target-index))
(source-index source-start (1+ source-index)))
((or (= target-index (the fixnum target-end))
(= source-index (the fixnum source-end)))
target-sequence)
(declare (fixnum target-index source-index))
(setf (aref target-sequence target-index)
(aref source-sequence source-index)))))
(defmacro list-replace-from-list ()
`(if (and (eq target-sequence source-sequence) (> target-start source-start))
(let ((new-elts (subseq source-sequence source-start
(+ (the fixnum source-start)
(the fixnum
(min (- (the fixnum target-end)
(the fixnum target-start))
(- (the fixnum source-end)
(the fixnum source-start))))))))
(do ((n new-elts (cdr n))
(o (nthcdr target-start target-sequence) (cdr o)))
((null n) target-sequence)
(rplaca o (car n))))
(do ((target-index target-start (1+ target-index))
(source-index source-start (1+ source-index))
(target-sequence-ref (nthcdr target-start target-sequence)
(cdr target-sequence-ref))
(source-sequence-ref (nthcdr source-start source-sequence)
(cdr source-sequence-ref)))
((or (= target-index (the fixnum target-end))
(= source-index (the fixnum source-end))
(null target-sequence-ref) (null source-sequence-ref))
target-sequence)
(declare (fixnum target-index source-index))
(rplaca target-sequence-ref (car source-sequence-ref)))))
(defmacro list-replace-from-mumble ()
`(do ((target-index target-start (1+ target-index))
(source-index source-start (1+ source-index))
(target-sequence-ref (nthcdr target-start target-sequence)
(cdr target-sequence-ref)))
((or (= target-index (the fixnum target-end))
(= source-index (the fixnum source-end))
(null target-sequence-ref))
target-sequence)
(declare (fixnum source-index target-index))
(rplaca target-sequence-ref (aref source-sequence source-index))))
(defmacro mumble-replace-from-list ()
`(do ((target-index target-start (1+ target-index))
(source-index source-start (1+ source-index))
(source-sequence (nthcdr source-start source-sequence)
(cdr source-sequence)))
((or (= target-index (the fixnum target-end))
(= source-index (the fixnum source-end))
(null source-sequence))
target-sequence)
(declare (fixnum target-index source-index))
(setf (aref target-sequence target-index) (car source-sequence))))
) ; eval-when
;;; The support routines for REPLACE are used by compiler transforms, so we
;;; worry about dealing with end being supplied as or defaulting to nil
;;; at this level.
(defun list-replace-from-list* (target-sequence source-sequence target-start
target-end source-start source-end)
(when (null target-end) (setq target-end (length target-sequence)))
(when (null source-end) (setq source-end (length source-sequence)))
(list-replace-from-list))
(defun list-replace-from-vector* (target-sequence source-sequence target-start
target-end source-start source-end)
(when (null target-end) (setq target-end (length target-sequence)))
(when (null source-end) (setq source-end (length source-sequence)))
(list-replace-from-mumble))
(defun vector-replace-from-list* (target-sequence source-sequence target-start
target-end source-start source-end)
(when (null target-end) (setq target-end (length target-sequence)))
(when (null source-end) (setq source-end (length source-sequence)))
(mumble-replace-from-list))
(defun vector-replace-from-vector* (target-sequence source-sequence
target-start target-end source-start
source-end)
(when (null target-end) (setq target-end (length target-sequence)))
(when (null source-end) (setq source-end (length source-sequence)))
(mumble-replace-from-mumble))
;;; REPLACE cannot default end arguments to the length of sequence since it
;;; is not an error to supply nil for their values. We must test for ends
;;; being nil in the body of the function.
(defun replace (target-sequence source-sequence &rest args &key
((:start1 target-start) 0)
((:end1 target-end))
((:start2 source-start) 0)
((:end2 source-end)))
"The target sequence is destructively modified by copying successive
elements into it from the source sequence."
(let ((target-end (or target-end (length target-sequence)))
(source-end (or source-end (length source-sequence))))
(declare (type (integer 0 #.most-positive-fixnum) target-start target-end source-start source-end))
(sequence::seq-dispatch target-sequence
(sequence::seq-dispatch source-sequence
(list-replace-from-list)
(list-replace-from-mumble)
(apply #'sequence:replace target-sequence source-sequence args))
(sequence::seq-dispatch source-sequence
(mumble-replace-from-list)
(mumble-replace-from-mumble)
(apply #'sequence:replace target-sequence source-sequence args))
(apply #'sequence:replace target-sequence source-sequence args))))