org.armedbear.lisp.replace.lisp Maven / Gradle / Ivy

Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl Show documentation
Common Lisp implementation running on the JVM
The newest version!
;;; 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))))