source: branches/1.1.x/src/org/armedbear/lisp/extensible-sequences-base.lisp

;;;This file only defines the minimum set of symbols and operators
;;;that is needed to make standard CL sequence functions refer to generic
;;;functions in the SEQUENCE package, without actually definining those
;;;generic functions and supporting code, which is in extensible-sequences.lisp.
;;;
;;;The rationale for splitting the code this way is that CLOS depends on
;;;some sequence functions, and if those in turn depend on CLOS we have
;;;a circular dependency.

(in-package :sequence)

(shadow '(ELT LENGTH COUNT "COUNT-IF" "COUNT-IF-NOT"
    "FIND" "FIND-IF" "FIND-IF-NOT"
    "POSITION" "POSITION-IF" "POSITION-IF-NOT"
    "SUBSEQ" "COPY-SEQ" "FILL"
    "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT"
    "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT"
    "REPLACE" "REVERSE" "NREVERSE" "REDUCE"
    "MISMATCH" "SEARCH"
    "DELETE" "DELETE-IF" "DELETE-IF-NOT"
    "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT"
    "DELETE-DUPLICATES" "REMOVE-DUPLICATES" "SORT" "STABLE-SORT"))

(export '(DOSEQUENCE
    
    MAKE-SEQUENCE-ITERATOR MAKE-SIMPLE-SEQUENCE-ITERATOR
    
    ITERATOR-STEP ITERATOR-ENDP ITERATOR-ELEMENT
    ITERATOR-INDEX ITERATOR-COPY
    
    WITH-SEQUENCE-ITERATOR WITH-SEQUENCE-ITERATOR-FUNCTIONS
    
    CANONIZE-TEST CANONIZE-KEY
    
    LENGTH ELT
    MAKE-SEQUENCE-LIKE ADJUST-SEQUENCE
     
    COUNT COUNT-IF COUNT-IF-NOT
    FIND FIND-IF FIND-IF-NOT
    POSITION POSITION-IF POSITION-IF-NOT
    SUBSEQ COPY-SEQ FILL
    NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT
    SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT
    REPLACE REVERSE NREVERSE REDUCE
    MISMATCH SEARCH
    DELETE DELETE-IF DELETE-IF-NOT
    REMOVE REMOVE-IF REMOVE-IF-NOT
    DELETE-DUPLICATES REMOVE-DUPLICATES SORT STABLE-SORT))

;;; Adapted from SBCL
;;; SEQ-DISPATCH does an efficient type-dispatch on the given SEQUENCE.
;;;
;;; FIXME: It might be worth making three cases here, LIST,
;;; SIMPLE-VECTOR, and VECTOR, instead of the current LIST and VECTOR.
;;; It tends to make code run faster but be bigger; some benchmarking
;;; is needed to decide.
(defmacro seq-dispatch
    (sequence list-form array-form &optional other-form)
  `(if (listp ,sequence)
       (let ((,sequence (ext:truly-the list ,sequence)))
         (declare (ignorable ,sequence))
         ,list-form)
       ,@(if other-form
             `((if (arrayp ,sequence)
                   (let ((,sequence (ext:truly-the vector ,sequence)))
                     (declare (ignorable ,sequence))
                     ,array-form)
                   (if (typep ,sequence 'sequence)
           ,other-form
           (error 'type-error
            :datum ,sequence :expected-type 'sequence))))
             `((let ((,sequence (ext:truly-the vector ,sequence)))
                 (declare (ignorable ,sequence))
                 ,array-form)))))

(defun %check-generic-sequence-bounds (seq start end)
  (let ((length (sequence:length seq)))
    (if (<= 0 start (or end length) length)
        (or end length)
        (sequence-bounding-indices-bad-error seq start end))))

(defun sequence-bounding-indices-bad-error (sequence start end)
  (let ((size (length sequence)))
    (error "The bounding indices ~S and ~S are bad for a sequence of length ~S"
     start end size)))

(defun %set-elt (sequence index value)
  (seq-dispatch sequence
     (sys::%set-elt sequence index value)
     (sys::%set-elt sequence index value)
     (setf (sequence:elt sequence index) value)))

(defsetf cl:elt %set-elt)

#|
    (error 'bounding-indices-bad-error
           :datum (cons start end)
           :expected-type `(cons (integer 0 ,size)
                                 (integer ,start ,size))
           :object sequence)))|#

(provide "EXTENSIBLE-SEQUENCES-BASE")