1.1.11: will be tagged as "sbcl-1.1.11"

[sbcl.git] / tests / seq.impure.lisp

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 2df75d1..9616cde 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -21,58 +21,84 @@
 
 (in-package :seq-test)
 
 
 (in-package :seq-test)
 

+;;; user-defined mock sequence class for testing generic versions of
+;;; sequence functions.
+(defclass list-backed-sequence (standard-object
+                                sequence)
+  ((elements :initarg :elements :type list :accessor %elements)))
+
+(defmethod sequence:make-sequence-like ((sequence list-backed-sequence) length
+                                        &rest args &key
+                                        initial-element initial-contents)
+  (declare (ignore initial-element initial-contents))
+  (make-instance 'list-backed-sequence
+                 :elements (apply #'sequence:make-sequence-like
+                                  '() length args)))
+
+(defmethod sequence:length ((sequence list-backed-sequence))
+  (length (%elements sequence)))
+
+(defmethod sequence:elt
+    ((sequence list-backed-sequence) index)
+  (nth index (%elements sequence)))
+
+(defmethod (setf sequence:elt)
+    (new-value (sequence list-backed-sequence) index)
+  (setf (nth index (%elements sequence)) new-value))
+

 ;;; helper functions for exercising SEQUENCE code on data of many
 ;;; specialized types, and in many different optimization scenarios
 (defun for-every-seq-1 (base-seq snippet)
 ;;; helper functions for exercising SEQUENCE code on data of many
 ;;; specialized types, and in many different optimization scenarios
 (defun for-every-seq-1 (base-seq snippet)

-  (dolist (seq-type '(list
-                      (simple-array t 1)
-                      (vector t)
-                      (simple-array character 1)
-                      (vector character)
-                      (simple-array (signed-byte 4) 1)
-                      (vector (signed-byte 4))))
-    (flet ((entirely (eltype)
-             (every (lambda (el) (typep el eltype)) base-seq)))
+  (labels
+      ((entirely (eltype)
+         (every (lambda (el) (typep el eltype)) base-seq))
+       (make-sequence-for-type (type)
+         (etypecase type
+           ((member list list-backed-sequence)
+            (coerce base-seq type))
+           ((cons (eql simple-array) (cons * (cons (eql 1) null)))
+            (destructuring-bind (eltype one) (rest type)
+              (when (entirely eltype)
+                (coerce base-seq type))))
+           ((cons (eql vector))
+            (destructuring-bind (eltype) (rest type)
+              (when (entirely eltype)
+                (let ((initial-element
+                        (cond ((subtypep eltype 'character)
+                               #\!)
+                              ((subtypep eltype 'number)
+                               0)
+                                (t #'error))))
+                  (replace (make-array
+                            (+ (length base-seq)
+                               (random 3))
+                            :element-type eltype
+                            :fill-pointer
+                            (length base-seq)
+                            :initial-element
+                            initial-element)
+                           base-seq))))))))
+    (dolist (seq-type '(list
+                        (simple-array t 1)
+                        (vector t)
+                        (simple-array character 1)
+                        (vector character)
+                        (simple-array (signed-byte 4) 1)
+                        (vector (signed-byte 4))
+                        list-backed-sequence))

       (dolist (declaredness '(nil t))
         (dolist (optimization '(((speed 3) (space 0))
                                 ((speed 2) (space 2))
                                 ((speed 1) (space 2))
                                 ((speed 0) (space 1))))
       (dolist (declaredness '(nil t))
         (dolist (optimization '(((speed 3) (space 0))
                                 ((speed 2) (space 2))
                                 ((speed 1) (space 2))
                                 ((speed 0) (space 1))))

-          (let* ((seq (if (eq seq-type 'list)
-                          (coerce base-seq 'list)
-                          (destructuring-bind (type-first &rest type-rest)
-                              seq-type
-                            (ecase type-first
-                              (simple-array
-                               (destructuring-bind (eltype one) type-rest
-                                 (assert (= one 1))
-                                 (if (entirely eltype)
-                                     (coerce base-seq seq-type)
-                                     (return))))
-                              (vector
-                               (destructuring-bind (eltype) type-rest
-                                 (if (entirely eltype)
-                                     (let ((initial-element
-                                            (cond ((subtypep eltype 'character)
-                                                   #\!)
-                                                  ((subtypep eltype 'number)
-                                                   0)
-                                                  (t #'error))))
-                                       (replace (make-array
-                                                 (+ (length base-seq)
-                                                    (random 3))
-                                                 :element-type eltype
-                                                 :fill-pointer
-                                                 (length base-seq)
-                                                 :initial-element
-                                                 initial-element)
-                                                base-seq))
-                                     (return))))))))
-                 (lambda-expr `(lambda (seq)
-                                 ,@(when declaredness
-                                     `((declare (type ,seq-type seq))))
-                                 (declare (optimize ,@optimization))
-                                 ,snippet)))
+          (let ((seq (make-sequence-for-type seq-type))
+                (lambda-expr `(lambda (seq)
+                                ,@(when declaredness
+                                    `((declare (type ,seq-type seq))))
+                                (declare (optimize ,@optimization))
+                                ,snippet)))
+            (when (not seq)
+              (return))

             (format t "~&~S~%" lambda-expr)
             (multiple-value-bind (fun warnings-p failure-p)
                 (compile nil lambda-expr)
             (format t "~&~S~%" lambda-expr)
             (multiple-value-bind (fun warnings-p failure-p)
                 (compile nil lambda-expr)

@@ -109,6 +135,12 @@
 (assert (eql 4 ; modified more, avoids charset technicalities completely
              (find 5 '(6 4) :test '>)))
 
 (assert (eql 4 ; modified more, avoids charset technicalities completely
              (find 5 '(6 4) :test '>)))
 

+(with-test (:name sequence:emptyp)
+  (for-every-seq #()
+    '((eq t (sequence:emptyp seq))))
+  (for-every-seq #(1)
+    '((eq nil (sequence:emptyp seq)))))
+

 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
 (for-every-seq #()
 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
 (for-every-seq #()

@@ -303,6 +335,24 @@
     ;; ... though not in all cases.
     (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
 
     ;; ... though not in all cases.
     (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
 

+;; CONCATENATE used to fail for generic sequences for result-type NULL.
+(with-test (:name (concatenate :result-type-null :bug-1162301))
+  (assert (sequence:emptyp (concatenate 'null)))
+
+  (for-every-seq #()
+    '((sequence:emptyp (concatenate 'null seq))
+      (sequence:emptyp (concatenate 'null seq seq))
+      (sequence:emptyp (concatenate 'null seq #()))
+      (sequence:emptyp (concatenate 'null seq ""))))
+
+  (for-every-seq #(1)
+    (mapcar (lambda (form)
+              `(typep (nth-value 1 (ignore-errors ,form)) 'type-error))
+            '((concatenate 'null seq)
+              (concatenate 'null seq seq)
+              (concatenate 'null seq #())
+              (concatenate 'null seq "2")))))
+

 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
 ;;; with user-defined types until sbcl-0.7.8.11
 (deftype list-typeoid () 'list)
 ;;; As pointed out by Raymond Toy on #lisp IRC, MERGE had some issues
 ;;; with user-defined types until sbcl-0.7.8.11
 (deftype list-typeoid () 'list)

@@ -351,10 +401,8 @@
                4))
     (assert-type-error (merge 'nil () () '<))
     ;; CONCATENATE
                4))
     (assert-type-error (merge 'nil () () '<))
     ;; CONCATENATE

-    (assert-type-error (concatenate 'null '(1) "2"))

     (assert-type-error (concatenate 'cons #() ()))
     (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6)))
     (assert-type-error (concatenate 'cons #() ()))
     (assert-type-error (concatenate '(cons t null) #(1 2 3) #(4 5 6)))

-    (assert (null (concatenate 'null () #())))

     (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
     (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3))
     (assert-type-error (concatenate 'nil '(3)))
     (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
     (assert (= (length (concatenate '(cons t cons) '(1) "34")) 3))
     (assert-type-error (concatenate 'nil '(3)))