X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fseq.lisp;h=4fb59114a432b7ab9e5e19024f46091ba8447dab;hb=769e1d8a825c587df85896dc971d0f90748e134e;hp=b49f616ae61fd6f7cdd6f4a9cbb3757a16ce0a7b;hpb=6298db769e00670920b3d5d2e2dc5426f9d64786;p=sbcl.git

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index b49f616..4fb5911 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -224,6 +224,7 @@
                               ;; This seems silly, is there something better?
                               '(integer 0 (0))))))
 
+(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error))
 (defun sequence-bounding-indices-bad-error (sequence start end)
   (let ((size (length sequence)))
     (error 'bounding-indices-bad-error
@@ -232,6 +233,7 @@
                                  (integer ,start ,size))
            :object sequence)))
 
+(declaim (ftype (function (t t t) nil) array-bounding-indices-bad-error))
 (defun array-bounding-indices-bad-error (array start end)
   (let ((size (array-total-size array)))
     (error 'bounding-indices-bad-error
@@ -239,6 +241,16 @@
            :expected-type `(cons (integer 0 ,size)
                                  (integer ,start ,size))
            :object array)))
+
+(declaim (ftype (function (t) nil) circular-list-error))
+(defun circular-list-error (list)
+  (let ((*print-circle* t))
+    (error 'simple-type-error
+           :format-control "List is circular:~%  ~S"
+           :format-arguments (list list)
+           :datum list
+           :type '(and list (satisfies list-length)))))
+
 
 (defun elt (sequence index)
   #!+sb-doc "Return the element of SEQUENCE specified by INDEX."
@@ -497,7 +509,8 @@
               (loop repeat n
                     do (setf pointer (cdr (rplaca pointer item))))))
           (loop while pointer
-                do (setf pointer (cdr (rplaca pointer item))))))))
+                do (setf pointer (cdr (rplaca pointer item)))))))
+  sequence)
 
 (defun vector-fill* (sequence item start end)
   (with-array-data ((data sequence)
@@ -519,22 +532,18 @@
                     (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)))))))
+    ;; DEFTRANSFORM for FILL will turn these into
+    ;; calls to UB*-BASH-FILL.
+    (etypecase data
+      #!+sb-unicode
+      ((simple-array character (*))
+       (let ((item (locally (declare (optimize (safety 3)))
+                     (the character item))))
+         (fill data item :start start :end end)))
+      ((simple-array base-char (*))
+       (let ((item (locally (declare (optimize (safety 3)))
+                     (the base-char item))))
+         (fill data item :start start :end end))))))
 
 (defun fill (sequence item &key (start 0) end)
   #!+sb-doc
@@ -672,7 +681,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
@@ -794,91 +803,98 @@
                   ,@decls
                   (tagbody
                      ,@forms))))))))))
-
-(eval-when (:compile-toplevel :execute)
-
-(sb!xc:defmacro concatenate-to-list (sequences)
-  `(let ((result (list nil)))
-     (do ((sequences ,sequences (cdr sequences))
-          (splice result))
-         ((null sequences) (cdr result))
-       (let ((sequence (car sequences)))
-         (sb!sequence:dosequence (e sequence)
-           (setq splice (cdr (rplacd splice (list e)))))))))
-
-(sb!xc:defmacro concatenate-to-mumble (output-type-spec sequences)
-  `(do ((seqs ,sequences (cdr seqs))
-        (total-length 0)
-        (lengths ()))
-       ((null seqs)
-        (do ((sequences ,sequences (cdr sequences))
-             (lengths lengths (cdr lengths))
-             (index 0)
-             (result (make-sequence ,output-type-spec total-length)))
-            ((= index total-length) result)
-          (declare (fixnum index))
-          (let ((sequence (car sequences)))
-            (sb!sequence:dosequence (e sequence)
-              (setf (aref result index) e)
-              (incf index)))))
-     (let ((length (length (car seqs))))
-       (declare (fixnum length))
-       (setq lengths (nconc lengths (list length)))
-       (setq total-length (+ total-length length)))))
-
-) ; EVAL-WHEN
 
 (defun concatenate (output-type-spec &rest sequences)
   #!+sb-doc
   "Return a new sequence of all the argument sequences concatenated together
   which shares no structure with the original argument sequences of the
   specified OUTPUT-TYPE-SPEC."
-  (let ((type (specifier-type output-type-spec)))
-  (cond
-    ((csubtypep type (specifier-type 'list))
-     (cond
-       ((type= type (specifier-type 'list))
-        (apply #'concat-to-list* sequences))
-       ((eq type *empty-type*)
-        (bad-sequence-type-error nil))
-       ((type= type (specifier-type 'null))
-        (if (every (lambda (x) (or (null x)
-                                   (and (vectorp x) (= (length x) 0))))
-                   sequences)
-            'nil
-            (sequence-type-length-mismatch-error
-             type
-             ;; FIXME: circular list issues.
-             (reduce #'+ sequences :key #'length))))
-       ((cons-type-p type)
-        (multiple-value-bind (min exactp)
-            (sb!kernel::cons-type-length-info type)
-          (let ((length (reduce #'+ sequences :key #'length)))
-            (if exactp
-                (unless (= length min)
-                  (sequence-type-length-mismatch-error type length))
-                (unless (>= length min)
-                  (sequence-type-length-mismatch-error type length)))
-            (apply #'concat-to-list* sequences))))
-       (t (sequence-type-too-hairy (type-specifier type)))))
-    ((csubtypep type (specifier-type 'vector))
-     (apply #'concat-to-simple* output-type-spec sequences))
-    ((and (csubtypep type (specifier-type 'sequence))
-          (find-class output-type-spec nil))
-     (coerce (apply #'concat-to-simple* 'vector sequences) output-type-spec))
-    (t
-     (bad-sequence-type-error output-type-spec)))))
-
-;;; internal frobs
-;;; FIXME: These are weird. They're never called anywhere except in
-;;; CONCATENATE. It seems to me that the macros ought to just
-;;; be expanded directly in CONCATENATE, or in CONCATENATE-STRING
-;;; and CONCATENATE-LIST variants. Failing that, these ought to be local
-;;; functions (FLET).
-(defun concat-to-list* (&rest sequences)
-  (concatenate-to-list sequences))
-(defun concat-to-simple* (type &rest sequences)
-  (concatenate-to-mumble type sequences))
+  (flet ((concat-to-list* (sequences)
+           (let ((result (list nil)))
+             (do ((sequences sequences (cdr sequences))
+                  (splice result))
+                 ((null sequences) (cdr result))
+               (let ((sequence (car sequences)))
+                 (sb!sequence:dosequence (e sequence)
+                   (setq splice (cdr (rplacd splice (list e)))))))))
+         (concat-to-simple* (type-spec sequences)
+           (do ((seqs sequences (cdr seqs))
+                (total-length 0)
+                (lengths ()))
+               ((null seqs)
+                (do ((sequences sequences (cdr sequences))
+                     (lengths lengths (cdr lengths))
+                     (index 0)
+                     (result (make-sequence type-spec total-length)))
+                    ((= index total-length) result)
+                  (declare (fixnum index))
+                  (let ((sequence (car sequences)))
+                    (sb!sequence:dosequence (e sequence)
+                      (setf (aref result index) e)
+                      (incf index)))))
+             (let ((length (length (car seqs))))
+               (declare (fixnum length))
+               (setq lengths (nconc lengths (list length)))
+               (setq total-length (+ total-length length))))))
+    (let ((type (specifier-type output-type-spec)))
+      (cond
+        ((csubtypep type (specifier-type 'list))
+         (cond
+           ((type= type (specifier-type 'list))
+            (concat-to-list* sequences))
+           ((eq type *empty-type*)
+            (bad-sequence-type-error nil))
+           ((type= type (specifier-type 'null))
+            (if (every (lambda (x) (or (null x)
+                                       (and (vectorp x) (= (length x) 0))))
+                       sequences)
+                'nil
+                (sequence-type-length-mismatch-error
+                 type
+                 ;; FIXME: circular list issues.
+                 (reduce #'+ sequences :key #'length))))
+           ((cons-type-p type)
+            (multiple-value-bind (min exactp)
+                (sb!kernel::cons-type-length-info type)
+              (let ((length (reduce #'+ sequences :key #'length)))
+                (if exactp
+                    (unless (= length min)
+                      (sequence-type-length-mismatch-error type length))
+                    (unless (>= length min)
+                      (sequence-type-length-mismatch-error type length)))
+                (concat-to-list* sequences))))
+           (t (sequence-type-too-hairy (type-specifier type)))))
+        ((csubtypep type (specifier-type 'vector))
+         (concat-to-simple* output-type-spec sequences))
+        ((and (csubtypep type (specifier-type 'sequence))
+              (find-class output-type-spec nil))
+         (coerce (concat-to-simple* 'vector sequences) output-type-spec))
+        (t
+         (bad-sequence-type-error output-type-spec))))))
+
+;;; Efficient out-of-line concatenate for strings. Compiler transforms
+;;; CONCATENATE 'STRING &co into these.
+(macrolet ((def (name element-type)
+             `(defun ,name (&rest sequences)
+                (declare (dynamic-extent sequences)
+                         (optimize speed)
+                         (optimize (sb!c::insert-array-bounds-checks 0)))
+                (let* ((lengths (mapcar #'length sequences))
+                       (result (make-array (the integer (apply #'+ lengths))
+                                           :element-type ',element-type))
+                       (start 0))
+                  (declare (index start))
+                  (dolist (seq sequences)
+                    (string-dispatch
+                        ((simple-array character (*))
+                         (simple-array base-char (*))
+                         t)
+                        seq
+                      (replace result seq :start1 start))
+                    (incf start (the index (pop lengths))))
+                  result))))
+  (def %concatenate-to-string character)
+  (def %concatenate-to-base-string base-char))
 
 ;;;; MAP and MAP-INTO
 
@@ -960,9 +976,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)
@@ -970,19 +986,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)
@@ -990,20 +1006,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)))
 
@@ -1233,7 +1249,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))
@@ -1376,7 +1392,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
@@ -1414,7 +1430,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
@@ -1452,7 +1468,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
@@ -1601,7 +1617,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
@@ -1618,7 +1634,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
@@ -1635,7 +1651,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
@@ -1787,7 +1803,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
@@ -1860,7 +1876,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
@@ -1980,7 +1996,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)))
@@ -1992,7 +2008,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)
@@ -2006,7 +2022,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)
@@ -2025,7 +2041,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
@@ -2078,7 +2094,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
@@ -2120,7 +2136,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
@@ -2211,7 +2227,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
@@ -2224,7 +2240,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
@@ -2237,7 +2253,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)
@@ -2250,7 +2266,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)
@@ -2264,7 +2280,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)
@@ -2277,7 +2293,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)
@@ -2326,7 +2342,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))
@@ -2344,7 +2360,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))
@@ -2364,7 +2380,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)
@@ -2472,7 +2488,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))
@@ -2582,7 +2598,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