X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=c76c58673d955f7675657c0450e2170152b4295f;hb=5d5894082c39ca44da75d38859d669c7b2108f6a;hp=eba8389974c32f60bbc17d8cbee12ad401ae6379;hpb=b86daba1860b622636d9e8f655a3f96de4d86801;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index eba8389..c76c586 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -20,6 +20,12 @@
 
 ;;;; utilities
 
+(defun %check-generic-sequence-bounds (seq start end)
+  (let ((length (sb!sequence:length seq)))
+    (if (<= 0 start (or end length) length)
+        (or end length)
+        (sequence-bounding-indices-bad-error seq start end))))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 (defparameter *sequence-keyword-info*
@@ -358,21 +364,38 @@
 ;;;; so we worry about dealing with END being supplied or defaulting
 ;;;; to NIL at this level.
 
-(defun vector-subseq* (sequence start &optional end)
+(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))
-  (declare (type (or null index) end))
-  (when (null end)
-    (setf end (length sequence)))
-  (unless (<= 0 start end (length sequence))
-    (sequence-bounding-indices-bad-error sequence start end))
-  (do ((old-index start (1+ old-index))
-       (new-index 0 (1+ new-index))
-       (copy (%make-sequence-like sequence (- end start))))
-      ((= old-index end) copy)
-    (declare (fixnum old-index new-index))
-    (setf (aref copy new-index)
-          (aref sequence old-index))))
+  (declare (type index start)
+           (type (or null index) end))
+  (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))))))
 
 (defun list-subseq* (sequence start end)
   (declare (type list sequence)
@@ -434,84 +457,95 @@
 
 ;;;; COPY-SEQ
 
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-copy-seq (sequence)
-  `(let ((length (length (the vector ,sequence))))
-     (declare (fixnum length))
-     (do ((index 0 (1+ index))
-          (copy (%make-sequence-like ,sequence length)))
-         ((= index length) copy)
-       (declare (fixnum index))
-       (setf (aref copy index) (aref ,sequence index)))))
-
-(sb!xc:defmacro list-copy-seq (list)
-  `(if (atom ,list) '()
-       (let ((result (cons (car ,list) '()) ))
-         (do ((x (cdr ,list) (cdr x))
-              (splice result
-                      (cdr (rplacd splice (cons (car x) '() ))) ))
-             ((atom x) (unless (null x)
-                               (rplacd splice x))
-                       result)))))
-
-) ; EVAL-WHEN
-
 (defun copy-seq (sequence)
   #!+sb-doc "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
   (seq-dispatch sequence
     (list-copy-seq* sequence)
-    (vector-copy-seq* sequence)
+    (vector-subseq* sequence 0 nil)
     (sb!sequence:copy-seq sequence)))
 
-;;; internal frobs
-
 (defun list-copy-seq* (sequence)
-  (list-copy-seq sequence))
-
-(defun vector-copy-seq* (sequence)
-  (declare (type vector sequence))
-  (vector-copy-seq sequence))
+  (!copy-list-macro sequence :check-proper-list t))
 
 ;;;; FILL
 
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro vector-fill (sequence item start end)
-  `(do ((index ,start (1+ index)))
-       ((= index (the fixnum ,end)) ,sequence)
-     (declare (fixnum index))
-     (setf (aref ,sequence index) ,item)))
-
-(sb!xc:defmacro list-fill (sequence item start end)
-  `(do ((current (nthcdr ,start ,sequence) (cdr current))
-        (index ,start (1+ index)))
-       ((or (atom current) (and end (= index (the fixnum ,end))))
-        sequence)
-     (declare (fixnum index))
-     (rplaca current ,item)))
-
-) ; EVAL-WHEN
-
-;;; The support routines for FILL are used by compiler transforms, so we
-;;; worry about dealing with END being supplied or defaulting to NIL
-;;; at this level.
-
 (defun list-fill* (sequence item start end)
-  (declare (list sequence))
-  (list-fill sequence item start end))
+  (declare (type list sequence)
+           (type unsigned-byte start)
+           (type (or null unsigned-byte) end))
+  (flet ((oops ()
+           (sequence-bounding-indices-bad-error sequence start end)))
+    (let ((pointer sequence))
+      (unless (zerop start)
+        ;; If START > 0 the list cannot be empty. So CDR down to it
+        ;; START-1 times, check that we still have something, then CDR
+        ;; the final time.
+        ;;
+        ;; If START was zero, the list may be empty if END is NIL or
+        ;; also zero.
+        (unless (= start 1)
+          (setf pointer (nthcdr (1- start) pointer)))
+        (if pointer
+            (pop pointer)
+            (oops)))
+      (if end
+          (let ((n (- end start)))
+            (declare (integer n))
+            (when (minusp n)
+              (oops))
+            (when (plusp n)
+              (loop repeat n
+                    do (setf pointer (cdr (rplaca pointer item))))))
+          (loop while pointer
+                do (setf pointer (cdr (rplaca pointer item)))))))
+  sequence)
 
 (defun vector-fill* (sequence item start end)
-  (declare (vector sequence))
-  (when (null end) (setq end (length sequence)))
-  (vector-fill sequence item start end))
-
-(define-sequence-traverser fill (sequence item &rest args &key start end)
-  #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :force-inline t
+                    :check-fill-pointer t)
+    (let ((setter (!find-data-vector-setter data)))
+      (declare (optimize (speed 3) (safety 0)))
+      (do ((index start (1+ index)))
+          ((= index end) sequence)
+        (declare (index index))
+        (funcall setter data index item)))))
+
+(defun string-fill* (sequence item start end)
+  (declare (string sequence))
+  (with-array-data ((data sequence)
+                    (start start)
+                    (end end)
+                    :force-inline t
+                    :check-fill-pointer t)
+    (macrolet ((frob ()
+                 `(locally (declare (optimize (safety 0) (speed 3)))
+                    (do ((i start (1+ i)))
+                        ((= i end) sequence)
+                     (declare (index i))
+                     (setf (aref data i) item)))))
+      (etypecase data
+        #!+sb-unicode
+        ((simple-array character (*))
+         (let ((item (locally (declare (optimize (safety 3)))
+                       (the character item))))
+           (frob)))
+        ((simple-array base-char (*))
+         (let ((item (locally (declare (optimize (safety 3)))
+                       (the base-char item))))
+           (frob)))))))
+
+(defun fill (sequence item &key (start 0) end)
+  #!+sb-doc
+  "Replace the specified elements of SEQUENCE with ITEM."
   (seq-dispatch sequence
-    (list-fill* sequence item start end)
-    (vector-fill* sequence item start end)
-    (apply #'sb!sequence:fill sequence item args)))
+   (list-fill* sequence item start end)
+   (vector-fill* sequence item start end)
+   (sb!sequence:fill sequence item
+                     :start start
+                     :end (%check-generic-sequence-bounds sequence start end))))
 
 ;;;; REPLACE
 
@@ -639,7 +673,7 @@
   #!+sb-doc
   "The target sequence is destructively modified by copying successive
    elements into it from the source sequence."
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or
          ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind
          ;; these things here so that legacy code gets the names it's
@@ -927,9 +961,9 @@
            (type list sequences))
   (let ((result nil))
     (flet ((f (&rest args)
-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))
              (push (apply fun args) result)))
-      (declare (dynamic-extent #'f))
+      (declare (truly-dynamic-extent #'f))
       (%map-for-effect #'f sequences))
     (nreverse result)))
 (defun %map-to-vector (output-type-spec fun sequences)
@@ -937,19 +971,19 @@
            (type list sequences))
   (let ((min-len 0))
     (flet ((f (&rest args)
-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))
              (declare (ignore args))
              (incf min-len)))
-      (declare (dynamic-extent #'f))
+      (declare (truly-dynamic-extent #'f))
       (%map-for-effect #'f sequences))
     (let ((result (make-sequence output-type-spec min-len))
           (i 0))
       (declare (type (simple-array * (*)) result))
       (flet ((f (&rest args)
-               (declare (dynamic-extent args))
+               (declare (truly-dynamic-extent args))
                (setf (aref result i) (apply fun args))
                (incf i)))
-        (declare (dynamic-extent #'f))
+        (declare (truly-dynamic-extent #'f))
         (%map-for-effect #'f sequences))
       result)))
 (defun %map-to-sequence (result-type fun sequences)
@@ -957,20 +991,20 @@
            (type list sequences))
   (let ((min-len 0))
     (flet ((f (&rest args)
-             (declare (dynamic-extent args))
+             (declare (truly-dynamic-extent args))
              (declare (ignore args))
              (incf min-len)))
-      (declare (dynamic-extent #'f))
+      (declare (truly-dynamic-extent #'f))
       (%map-for-effect #'f sequences))
     (let ((result (make-sequence result-type min-len)))
       (multiple-value-bind (state limit from-end step endp elt setelt)
           (sb!sequence:make-sequence-iterator result)
         (declare (ignore limit endp elt))
         (flet ((f (&rest args)
-                 (declare (dynamic-extent args))
+                 (declare (truly-dynamic-extent args))
                  (funcall setelt (apply fun args) result state)
                  (setq state (funcall step result state from-end))))
-          (declare (dynamic-extent #'f))
+          (declare (truly-dynamic-extent #'f))
           (%map-for-effect #'f sequences)))
       result)))
 
@@ -1200,7 +1234,7 @@
 (define-sequence-traverser reduce (function sequence &rest args &key key
                                    from-end start end (initial-value nil ivp))
   (declare (type index start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((start start)
         (end (or end length)))
     (declare (type index start end))
@@ -1343,7 +1377,7 @@
   "Return a sequence formed by destructively removing the specified ITEM from
   the given SEQUENCE."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1381,7 +1415,7 @@
   "Return a sequence formed by destructively removing the elements satisfying
   the specified PREDICATE from the given SEQUENCE."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1419,7 +1453,7 @@
   "Return a sequence formed by destructively removing the elements not
   satisfying the specified PREDICATE from the given SEQUENCE."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1568,7 +1602,7 @@
   "Return a copy of SEQUENCE with elements satisfying the test (default is
    EQL) with ITEM removed."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1585,7 +1619,7 @@
   #!+sb-doc
   "Return a copy of sequence with elements satisfying PREDICATE removed."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1602,7 +1636,7 @@
   #!+sb-doc
   "Return a copy of sequence with elements not satisfying PREDICATE removed."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (seq-dispatch sequence
@@ -1754,7 +1788,7 @@
 
    The :TEST-NOT argument is deprecated."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (if sequence
         (list-remove-duplicates* sequence test test-not
@@ -1827,7 +1861,7 @@
    given sequence, is returned.
 
    The :TEST-NOT argument is deprecated."
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (if sequence
         (list-delete-duplicates* sequence test test-not
@@ -1947,7 +1981,7 @@
   "Return a sequence of the same kind as SEQUENCE with the same elements,
   except that all elements equal to OLD are replaced with NEW."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (type index end))
     (subst-dispatch 'normal)))
@@ -1959,7 +1993,7 @@
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements satisfying the PRED are replaced with NEW."
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (declare (fixnum start))
   (let ((end (or end length))
         (test predicate)
@@ -1973,7 +2007,7 @@
   #!+sb-doc
   "Return a sequence of the same kind as SEQUENCE with the same elements
   except that all elements not satisfying the PRED are replaced with NEW."
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (declare (fixnum start))
   (let ((end (or end length))
         (test predicate)
@@ -1992,7 +2026,7 @@
   except that all elements equal to OLD are replaced with NEW. SEQUENCE
   may be destructively modified."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (seq-dispatch sequence
       (if from-end
@@ -2045,7 +2079,7 @@
    except that all elements satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (fixnum end))
     (seq-dispatch sequence
@@ -2087,7 +2121,7 @@
    except that all elements not satisfying PREDICATE are replaced with NEW.
    SEQUENCE may be destructively modified."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length)))
     (declare (fixnum end))
     (seq-dispatch sequence
@@ -2145,8 +2179,9 @@
                                             (frob sequence t)
                                             (frob sequence nil))))
                        (typecase sequence
-                         (simple-vector (frob2))
-                         (simple-base-string (frob2))
+                         #!+sb-unicode
+                         ((simple-array character (*)) (frob2))
+                         ((simple-array base-char (*)) (frob2))
                          (t (vector*-frob sequence))))
                    (declare (type (or index null) p))
                    (values f (and p (the index (- p offset)))))))))
@@ -2177,7 +2212,7 @@
 
 (defun find
     (item sequence &rest args &key from-end (start 0) end key test test-not)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 0 (%find-position
                   item sequence from-end start end
@@ -2190,7 +2225,7 @@
     (apply #'sb!sequence:find item sequence args)))
 (defun position
     (item sequence &rest args &key from-end (start 0) end key test test-not)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 1 (%find-position
                   item sequence from-end start end
@@ -2203,7 +2238,7 @@
     (apply #'sb!sequence:position item sequence args)))
 
 (defun find-if (predicate sequence &rest args &key from-end (start 0) end key)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 0 (%find-position-if
                   (%coerce-callable-to-fun predicate)
@@ -2216,7 +2251,7 @@
     (apply #'sb!sequence:find-if predicate sequence args)))
 (defun position-if
     (predicate sequence &rest args &key from-end (start 0) end key)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 1 (%find-position-if
                   (%coerce-callable-to-fun predicate)
@@ -2230,7 +2265,7 @@
 
 (defun find-if-not
     (predicate sequence &rest args &key from-end (start 0) end key)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 0 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)
@@ -2243,7 +2278,7 @@
     (apply #'sb!sequence:find-if-not predicate sequence args)))
 (defun position-if-not
     (predicate sequence &rest args &key from-end (start 0) end key)
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (seq-dispatch sequence
     (nth-value 1 (%find-position-if-not
                   (%coerce-callable-to-fun predicate)
@@ -2292,7 +2327,7 @@
   #!+sb-doc
   "Return the number of elements in SEQUENCE satisfying PRED(el)."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length))
         (pred (%coerce-callable-to-fun pred)))
     (declare (type index end))
@@ -2310,7 +2345,7 @@
   #!+sb-doc
   "Return the number of elements in SEQUENCE not satisfying TEST(el)."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end (or end length))
         (pred (%coerce-callable-to-fun pred)))
     (declare (type index end))
@@ -2330,7 +2365,7 @@
   "Return the number of elements in SEQUENCE satisfying a test with ITEM,
    which defaults to EQL."
   (declare (fixnum start))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (when (and test-p test-not-p)
     ;; ANSI Common Lisp has left the behavior in this situation unspecified.
     ;; (CLHS 17.2.1)
@@ -2438,7 +2473,7 @@
    :FROM-END argument is given, then one plus the index of the rightmost
    position in which the sequences differ is returned."
   (declare (fixnum start1 start2))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let* ((end1 (or end1 length1))
          (end2 (or end2 length2)))
     (declare (type index end1 end2))
@@ -2548,7 +2583,7 @@
     (sequence1 sequence2 &rest args &key
      from-end test test-not start1 end1 start2 end2 key)
   (declare (fixnum start1 start2))
-  (declare (dynamic-extent args))
+  (declare (truly-dynamic-extent args))
   (let ((end1 (or end1 length1))
         (end2 (or end2 length2)))
     (seq-dispatch sequence2