1.0.17.21: LIST-FILL* return value (regression 1.0.12.16)

[sbcl.git] / src / code / seq.lisp

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 6ff9ebc..7cf17f4 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -20,6 +20,12 @@
 \f
 ;;;; utilities
 
 \f
 ;;;; 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*
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
 (defparameter *sequence-keyword-info*

@@ -41,8 +47,7 @@
                      nil
                      (if (<= 0 ,start ,length)
                          ,start
                      nil
                      (if (<= 0 ,start ,length)
                          ,start

-                         (signal-bounding-indices-bad-error ,sequence
-                                                            ,start ,end))
+                         (sequence-bounding-indices-bad-error ,sequence ,start ,end))

                      index)
                   `(,end
                     nil
                      index)
                   `(,end
                     nil

@@ -55,8 +60,7 @@
                         ;; FIXME: defend against non-number non-NIL
                         ;; stuff?
                         ,end
                         ;; FIXME: defend against non-number non-NIL
                         ;; stuff?
                         ,end

-                        (signal-bounding-indices-bad-error ,sequence
-                                                           ,start ,end))
+                        (sequence-bounding-indices-bad-error ,sequence ,start ,end))

                     (or null index)))))
               '((start end length sequence)
                 (start1 end1 length1 sequence1)
                     (or null index)))))
               '((start end length sequence)
                 (start1 end1 length1 sequence1)

@@ -220,13 +224,21 @@
                               ;; This seems silly, is there something better?
                               '(integer 0 (0))))))
 
                               ;; This seems silly, is there something better?
                               '(integer 0 (0))))))
 

-(defun signal-bounding-indices-bad-error (sequence start end)
-  (let ((length (length sequence)))
+(defun sequence-bounding-indices-bad-error (sequence start end)
+  (let ((size (length sequence)))

     (error 'bounding-indices-bad-error
            :datum (cons start end)
     (error 'bounding-indices-bad-error
            :datum (cons start end)

-           :expected-type `(cons (integer 0 ,length)
-                                 (or null (integer ,start ,length)))
+           :expected-type `(cons (integer 0 ,size)
+                                 (integer ,start ,size))

            :object sequence)))
            :object sequence)))

+
+(defun array-bounding-indices-bad-error (array start end)
+  (let ((size (array-total-size array)))
+    (error 'bounding-indices-bad-error
+           :datum (cons start end)
+           :expected-type `(cons (integer 0 ,size)
+                                 (integer ,start ,size))
+           :object array)))

 \f
 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."
 \f
 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."

@@ -352,40 +364,87 @@
 ;;;; so we worry about dealing with END being supplied or defaulting
 ;;;; to NIL at this level.
 
 ;;;; 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 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))
-    (signal-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))))
-
-(defun list-subseq* (sequence start &optional end)
-  (declare (type list sequence))
-  ;; the INDEX declaration isn't actually mandatory, but it's true for
-  ;; all practical purposes.
-  (declare (type index start))
-  (declare (type (or null index) end))
-  (do ((list sequence (cdr list))
-       (index 0 (1+ index))
-       (result nil))
-      (nil)
-    (cond
-      ((null list) (if (or (and end (> end index))
-                           (< index start))
-                       (signal-bounding-indices-bad-error sequence start end)
-                       (return (nreverse result))))
-      ((< index start) nil)
-      ((and end (= index end)) (return (nreverse result)))
-      (t (push (car list) result)))))
+  (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)
+           (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.
+        (when (> 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)
+              (let* ((head (list nil))
+                     (tail head))
+                (macrolet ((pop-one ()
+                             `(let ((tmp (list (pop pointer))))
+                                (setf (cdr tail) tmp
+                                      tail tmp))))
+                  ;; Bignum case
+                  (loop until (fixnump n)
+                        do (pop-one)
+                           (decf n))
+                  ;; Fixnum case, but leave last element, so we should
+                  ;; still have something left in the sequence.
+                  (let ((m (1- n)))
+                    (declare (fixnum m))
+                    (loop repeat m
+                          do (pop-one)))
+                  (unless pointer
+                    (oops))
+                  ;; OK, pop the last one.
+                  (pop-one)
+                  (cdr head)))))
+            (loop while pointer
+                  collect (pop pointer))))))

 
 (defun subseq (sequence start &optional end)
   #!+sb-doc
 
 (defun subseq (sequence start &optional end)
   #!+sb-doc

@@ -398,84 +457,95 @@
 \f
 ;;;; COPY-SEQ
 
 \f
 ;;;; 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)
 (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)))
 
     (sb!sequence:copy-seq sequence)))
 

-;;; internal frobs
-

 (defun list-copy-seq* (sequence)
 (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))

 \f
 ;;;; FILL
 
 \f
 ;;;; 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)
 (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)
 
 (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
   (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))))

 \f
 ;;;; REPLACE
 
 \f
 ;;;; REPLACE
 

@@ -1682,20 +1752,22 @@
     (do ((elt))
         ((= index end))
       (setq elt (aref vector index))
     (do ((elt))
         ((= index end))
       (setq elt (aref vector index))

-      ;; FIXME: Relying on POSITION allowing both :TEST and :TEST-NOT
-      ;; arguments simultaneously is a little fragile, since ANSI says
-      ;; we can't depend on it, so we need to remember to keep that
-      ;; extension in our implementation. It'd probably be better to
-      ;; rewrite this to avoid passing both (as
-      ;; LIST-REMOVE-DUPLICATES* was rewritten ca. sbcl-0.7.12.18).

       (unless (or (and from-end
       (unless (or (and from-end

-                       (position (apply-key key elt) result
-                                 :start start :end jndex
-                                 :test test :test-not test-not :key key))
+                       (if test-not
+                           (position (apply-key key elt) result
+                                     :start start :end jndex
+                                     :test-not test-not :key key)
+                           (position (apply-key key elt) result
+                                     :start start :end jndex
+                                     :test test :key key)))

                   (and (not from-end)
                   (and (not from-end)

-                       (position (apply-key key elt) vector
-                                 :start (1+ index) :end end
-                                 :test test :test-not test-not :key key)))
+                       (if test-not
+                           (position (apply-key key elt) vector
+                                     :start (1+ index) :end end
+                                     :test-not test-not :key key)
+                           (position (apply-key key elt) vector
+                                     :start (1+ index) :end end
+                                     :test test :key key))))

         (setf (aref result jndex) elt)
         (setq jndex (1+ jndex)))
       (setq index (1+ index)))
         (setf (aref result jndex) elt)
         (setq jndex (1+ jndex)))
       (setq index (1+ index)))

@@ -1770,9 +1842,15 @@
          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))
          (setf (aref vector jndex) (aref vector index))))
     (declare (fixnum index jndex))
     (setf (aref vector jndex) (aref vector index))

-    (unless (position (apply-key key (aref vector index)) vector :key key
-                      :start (if from-end start (1+ index)) :test test
-                      :end (if from-end jndex end) :test-not test-not)
+    (unless (if test-not
+                (position (apply-key key (aref vector index)) vector :key key
+                          :start (if from-end start (1+ index))
+                          :end (if from-end jndex end)
+                          :test-not test-not)
+                (position (apply-key key (aref vector index)) vector :key key
+                          :start (if from-end start (1+ index))
+                          :end (if from-end jndex end)
+                          :test test))

       (setq jndex (1+ jndex)))))
 
 (define-sequence-traverser delete-duplicates
       (setq jndex (1+ jndex)))))
 
 (define-sequence-traverser delete-duplicates

@@ -2094,15 +2172,16 @@
                (frob sequence-arg from-end)
                (with-array-data ((sequence sequence-arg :offset-var offset)
                                  (start start)
                (frob sequence-arg from-end)
                (with-array-data ((sequence sequence-arg :offset-var offset)
                                  (start start)

-                                 (end (%check-vector-sequence-bounds
-                                       sequence-arg start end)))
+                                 (end end)
+                                 :check-fill-pointer t)

                  (multiple-value-bind (f p)
                      (macrolet ((frob2 () '(if from-end
                                             (frob sequence t)
                                             (frob sequence nil))))
                        (typecase sequence
                  (multiple-value-bind (f p)
                      (macrolet ((frob2 () '(if from-end
                                             (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)))))))))
                          (t (vector*-frob sequence))))
                    (declare (type (or index null) p))
                    (values f (and p (the index (- p offset)))))))))

@@ -2512,15 +2591,6 @@
       (vector-search sequence2 sequence1)
       (apply #'sb!sequence:search sequence1 sequence2 args))))
 
       (vector-search sequence2 sequence1)
       (apply #'sb!sequence:search sequence1 sequence2 args))))
 

-(sb!xc:defmacro string-dispatch ((&rest types) var &body body)
-  (let ((fun (gensym "STRING-DISPATCH-FUN-")))
-    `(flet ((,fun (,var)
-              ,@body))
-       (declare (inline ,fun))
-       (etypecase ,var
-         ,@(loop for type in types
-                 collect `(,type (,fun (the ,type ,var))))))))
-

 ;;; FIXME: this was originally in array.lisp; it might be better to
 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
 ;;; a new early-seq.lisp file.
 ;;; FIXME: this was originally in array.lisp; it might be better to
 ;;; put it back there, and make DOSEQUENCE and SEQ-DISPATCH be in
 ;;; a new early-seq.lisp file.

@@ -2542,4 +2612,4 @@
                                axis (car dims) contents (length contents)))
                       (sb!sequence:dosequence (content contents)
                         (frob (1+ axis) (cdr dims) content))))))
                                axis (car dims) contents (length contents)))
                       (sb!sequence:dosequence (content contents)
                         (frob (1+ axis) (cdr dims) content))))))

-      (frob 0 dimensions initial-contents))))
\ No newline at end of file
+      (frob 0 dimensions initial-contents))))