(typecase expanded-type
(atom (cond
((eq expanded-type 'string) '(vector character))
- ((eq expanded-type 'simple-string) '(simple-array character (*)))
+ ((eq expanded-type 'simple-string)
+ '(simple-array character (*)))
(t type)))
(cons (cond
- ((eq (car expanded-type) 'string) `(vector character ,@(cdr expanded-type)))
+ ((eq (car expanded-type) 'string)
+ `(vector character ,@(cdr expanded-type)))
((eq (car expanded-type) 'simple-string)
`(simple-array character ,(if (cdr expanded-type)
(cdr expanded-type)
'(*))))
- (t type)))
- (t type)))
+ (t type)))))
(type (specifier-type adjusted-type)))
(cond ((csubtypep type (specifier-type 'list))
(cond
\f
;;;; SUBSEQ
;;;;
+
+(define-array-dispatch vector-subseq-dispatch (array start end)
+ (declare (optimize speed (safety 0)))
+ (declare (type index start end))
+ (subseq array start end))
+
;;;; The support routines for SUBSEQ are used by compiler transforms,
;;;; so we worry about dealing with END being supplied or defaulting
;;;; to NIL at this level.
-(defun string-subseq* (sequence start end)
- (with-array-data ((data sequence)
- (start start)
- (end end)
- :force-inline t
- :check-fill-pointer t)
- (declare (optimize (speed 3) (safety 0)))
- (string-dispatch ((simple-array character (*))
- (simple-array base-char (*))
- (vector nil))
- data
- (subseq data start end))))
-
(defun vector-subseq* (sequence start end)
(declare (type vector sequence))
(declare (type index start)
- (type (or null index) end))
+ (type (or null index) end)
+ (optimize speed))
(with-array-data ((data sequence)
(start start)
(end end)
:check-fill-pointer t
:force-inline t)
- (let* ((copy (%make-sequence-like sequence (- end start)))
- (setter (!find-data-vector-setter copy))
- (reffer (!find-data-vector-reffer data)))
- (declare (optimize (speed 3) (safety 0)))
- (do ((old-index start (1+ old-index))
- (new-index 0 (1+ new-index)))
- ((= old-index end) copy)
- (declare (index old-index new-index))
- (funcall setter copy new-index
- (funcall reffer data old-index))))))
+ (vector-subseq-dispatch data start end)))
(defun list-subseq* (sequence start end)
(declare (type list sequence)
(define-sequence-traverser replace
(sequence1 sequence2 &rest args &key start1 end1 start2 end2)
#!+sb-doc
- "The target sequence is destructively modified by copying successive
- elements into it from the source sequence."
+ "Destructively modifies SEQUENCE1 by copying successive elements
+into it from the SEQUENCE2.
+
+Elements are copied to the subseqeuence bounded by START1 and END1,
+from the subsequence bounded by START2 and END2. If these subsequences
+are not of the same length, then the shorter length determines how
+many elements are copied."
(declare (truly-dynamic-extent args))
(let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or
;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind
(let ((,sequence ,s))
(seq-dispatch ,sequence
(dolist (,e ,sequence ,return) ,@body)
- (dovector (,e ,sequence ,return) ,@body)
+ (do-vector-data (,e ,sequence ,return) ,@body)
(multiple-value-bind (state limit from-end step endp elt)
(sb!sequence:make-sequence-iterator ,sequence)
(do ((state state (funcall step ,sequence state from-end)))
(def %concatenate-to-string character)
(def %concatenate-to-base-string base-char))
\f
-;;;; MAP and MAP-INTO
+;;;; MAP
;;; helper functions to handle arity-1 subcases of MAP
(declaim (ftype (function (function sequence) list) %map-list-arity-1))
first-sequence
more-sequences))
-;;; KLUDGE: MAP has been rewritten substantially since the fork from
-;;; CMU CL in order to give reasonable performance, but this
-;;; implementation of MAP-INTO still has the same problems as the old
-;;; MAP code. Ideally, MAP-INTO should be rewritten to be efficient in
-;;; the same way that the corresponding cases of MAP have been
-;;; rewritten. Instead of doing it now, though, it's easier to wait
-;;; until we have DYNAMIC-EXTENT, at which time it should become
-;;; extremely easy to define a reasonably efficient MAP-INTO in terms
-;;; of (MAP NIL ..). -- WHN 20000920
+;;;; MAP-INTO
+
+(defmacro map-into-lambda (sequences params &body body)
+ (check-type sequences symbol)
+ `(flet ((f ,params ,@body))
+ (declare (truly-dynamic-extent #'f))
+ ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal,
+ ;; hence the awkward flip between MAP and LOOP.
+ (if ,sequences
+ (apply #'map nil #'f ,sequences)
+ (loop (f)))))
+
+(define-array-dispatch vector-map-into (data start end fun sequences)
+ (declare (optimize speed (safety 0))
+ (type index start end)
+ (type function fun)
+ (type list sequences))
+ (let ((index start))
+ (declare (type index index))
+ (block mapping
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args))
+ (when (eql index end)
+ (return-from mapping))
+ (setf (aref data index) (apply fun args))
+ (incf index)))
+ index))
+
+;;; Uses the machinery of (MAP NIL ...). For non-vectors we avoid
+;;; computing the length of the result sequence since we can detect
+;;; the end during mapping (if MAP even gets that far).
+;;;
+;;; For each result type, define a mapping function which is
+;;; responsible for replacing RESULT-SEQUENCE elements and for
+;;; terminating itself if the end of RESULT-SEQUENCE is reached.
+;;; The mapping function is defined with MAP-INTO-LAMBDA.
+;;;
+;;; MAP-INTO-LAMBDAs are optimized since they are the inner loops.
+;;; Because we are manually doing bounds checking with known types,
+;;; safety is turned off for vectors and lists but kept for generic
+;;; sequences.
(defun map-into (result-sequence function &rest sequences)
- (let* ((fp-result
- (and (arrayp result-sequence)
- (array-has-fill-pointer-p result-sequence)))
- (len (apply #'min
- (if fp-result
- (array-dimension result-sequence 0)
- (length result-sequence))
- (mapcar #'length sequences))))
-
- (when fp-result
- (setf (fill-pointer result-sequence) len))
-
- (let ((really-fun (%coerce-callable-to-fun function)))
- (dotimes (index len)
- (setf (elt result-sequence index)
- (apply really-fun
- (mapcar (lambda (seq) (elt seq index))
- sequences))))))
+ (let ((really-fun (%coerce-callable-to-fun function)))
+ (etypecase result-sequence
+ (vector
+ (with-array-data ((data result-sequence) (start) (end)
+ ;; MAP-INTO ignores fill pointer when mapping
+ :check-fill-pointer nil)
+ (let ((new-end (vector-map-into data start end really-fun sequences)))
+ (when (array-has-fill-pointer-p result-sequence)
+ (setf (fill-pointer result-sequence) (- new-end start))))))
+ (list
+ (let ((node result-sequence))
+ (declare (type list node))
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args)
+ (optimize speed (safety 0)))
+ (when (null node)
+ (return-from map-into result-sequence))
+ (setf (car node) (apply really-fun args))
+ (setf node (cdr node)))))
+ (sequence
+ (multiple-value-bind (iter limit from-end)
+ (sb!sequence:make-sequence-iterator result-sequence)
+ (map-into-lambda sequences (&rest args)
+ (declare (truly-dynamic-extent args) (optimize speed))
+ (when (sb!sequence:iterator-endp result-sequence
+ iter limit from-end)
+ (return-from map-into result-sequence))
+ (setf (sb!sequence:iterator-element result-sequence iter)
+ (apply really-fun args))
+ (setf iter (sb!sequence:iterator-step result-sequence
+ iter from-end)))))))
result-sequence)
\f
;;;; quantifiers
;; from the old seq.lisp into target-seq.lisp.
(define-compiler-macro ,name (pred first-seq &rest more-seqs)
(let ((elements (make-gensym-list (1+ (length more-seqs))))
- (blockname (gensym "BLOCK")))
+ (blockname (sb!xc:gensym "BLOCK")))
(once-only ((pred pred))
`(block ,blockname
(map nil
(let ((end (or end length)))
(seq-dispatch sequence
(if from-end
- (let ((length (length sequence)))
- (nreverse (nlist-substitute*
- new old (nreverse (the list sequence))
- test test-not (- length end) (- length start)
- count key)))
+ (nreverse (nlist-substitute*
+ new old (nreverse (the list sequence))
+ test test-not (- length end) (- length start)
+ count key))
(nlist-substitute* new old sequence
test test-not start end count key))
(if from-end
(declare (fixnum end))
(seq-dispatch sequence
(if from-end
- (let ((length (length sequence)))
- (nreverse (nlist-substitute-if*
- new predicate (nreverse (the list sequence))
- (- length end) (- length start) count key)))
+ (nreverse (nlist-substitute-if*
+ new predicate (nreverse (the list sequence))
+ (- length end) (- length start) count key))
(nlist-substitute-if* new predicate sequence
start end count key))
(if from-end
(declare (fixnum end))
(seq-dispatch sequence
(if from-end
- (let ((length (length sequence)))
- (nreverse (nlist-substitute-if-not*
- new predicate (nreverse (the list sequence))
- (- length end) (- length start) count key)))
+ (nreverse (nlist-substitute-if-not*
+ new predicate (nreverse (the list sequence))
+ (- length end) (- length start) count key))
(nlist-substitute-if-not* new predicate sequence
start end count key))
(if from-end
(macrolet (;; shared logic for defining %FIND-POSITION and
;; %FIND-POSITION-IF in terms of various inlineable cases
;; of the expression defined in FROB and VECTOR*-FROB
- (frobs ()
+ (frobs (&optional bit-frob)
`(seq-dispatch sequence-arg
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(end end)
:check-fill-pointer t)
(multiple-value-bind (f p)
- (macrolet ((frob2 () '(if from-end
- (frob sequence t)
- (frob sequence nil))))
+ (macrolet ((frob2 () `(if from-end
+ (frob sequence t)
+ (frob sequence nil))))
(typecase sequence
#!+sb-unicode
((simple-array character (*)) (frob2))
((simple-array base-char (*)) (frob2))
- (t (vector*-frob sequence))))
+ ,@(when bit-frob
+ `((simple-bit-vector
+ (if (and (typep item 'bit)
+ (eq #'identity key)
+ (or (eq #'eq test)
+ (eq #'eql test)
+ (eq #'equal test)))
+ (let ((p (%bit-position item sequence
+ from-end start end)))
+ (if p
+ (values item p)
+ (values nil nil)))
+ (vector*-frob sequence)))))
+ (t
+ (vector*-frob sequence))))
(declare (type (or index null) p))
(values f (and p (the index (- p offset)))))))))
(defun %find-position (item sequence-arg from-end start end key test)
(vector*-frob (sequence)
`(%find-position-vector-macro item ,sequence
from-end start end key test)))
- (frobs)))
+ (frobs t)))
(defun %find-position-if (predicate sequence-arg from-end start end key)
(macrolet ((frob (sequence from-end)
`(%find-position-if predicate ,sequence
projects / sbcl.git / blobdiff