remove stray debugging code from condition-related patches

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

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 7de0756..e497115 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -21,58 +21,82 @@
 
 (in-package :seq-test)
 
 
 (in-package :seq-test)
 

+(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)

@@ -1139,4 +1163,93 @@
     (assert (raises-error? (concatenate type "qu" '(#\u #\x))))
     (assert (raises-error? (make-sequence type 4 :initial-element #\u)))))
 
     (assert (raises-error? (concatenate type "qu" '(#\u #\x))))
     (assert (raises-error? (make-sequence type 4 :initial-element #\u)))))
 

+(defun test-bit-position (size set start end from-end res)
+  (let ((v (make-array size :element-type 'bit :initial-element 0)))
+    (dolist (i set)
+      (setf (bit v i) 1))
+    (dolist (f (list (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (assert (eql b 1))
+                                 (position 1 (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the vector v) :start s :end e :from-end fe)))))
+      (let ((got (funcall f 1 v start end from-end)))
+        (unless (eql res got)
+          (cerror "Continue" "POSITION 1, Wanted ~S, got ~S.~%  size = ~S, set = ~S, from-end = ~S"
+                  res got
+                  size set from-end)))))
+  (let ((v (make-array size :element-type 'bit :initial-element 1)))
+    (dolist (i set)
+      (setf (bit v i) 0))
+    (dolist (f (list (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (assert (eql b 0))
+                                 (position 0 (the bit-vector v) :start s :end e :from-end fe)))
+                     (compile nil
+                              `(lambda (b v s e fe)
+                                 (position b (the vector v) :start s :end e :from-end fe)))))
+      (let ((got (funcall f 0 v start end from-end)))
+        (unless (eql res got)
+          (cerror "Continue" "POSITION 0, Wanted ~S, got ~S.~%  size = ~S, set = ~S, from-end = ~S"
+                  res got
+                  size set from-end))))))
+
+(defun random-test-bit-position (n)
+  (loop repeat n
+        do (let* ((vector (make-array (+ 2 (random 5000)) :element-type 'bit))
+                  (offset (random (1- (length vector))))
+                  (size (1+ (random (- (length vector) offset))))
+                  (disp (make-array size :element-type 'bit :displaced-to vector
+                                         :displaced-index-offset offset)))
+             (assert (plusp size))
+             (loop repeat 10
+                   do (setf (bit vector (random (length vector))) 1))
+             (flet ((test (orig)
+                      (declare (bit-vector orig))
+                      (let ((copy (coerce orig 'simple-vector))
+                            (p0 (random (length orig)))
+                            (p1 (1+ (random (length orig)))))
+                        (multiple-value-bind (s e)
+                            (if (> p1 p0)
+                                (values p0 p1)
+                                (values p1 p0))
+                          (assert (eql (position 1 copy :start s :end e)
+                                       (position 1 orig :start s :end e)))
+                          (assert (eql (position 1 copy :start s :end e :from-end t)
+                                       (position 1 orig :start s :end e :from-end t)))))))
+               (test vector)
+               (test disp)))))
+
+(with-test (:name :bit-position)
+  (test-bit-position 0 (list) 0 0 nil nil)
+  (test-bit-position 0 (list) 0 0 t nil)
+  (test-bit-position 1 (list 0) 0 0 nil nil)
+  (test-bit-position 1 (list 0) 0 0 t nil)
+  (test-bit-position 1 (list 0) 0 1 nil 0)
+  (test-bit-position 1 (list 0) 0 1 t 0)
+  (test-bit-position 10 (list 0 1) 0 1 nil 0)
+  (test-bit-position 10 (list 0 1) 1 1 nil nil)
+  (test-bit-position 10 (list 0 1) 0 1 t 0)
+  (test-bit-position 10 (list 0 1) 1 1 t nil)
+  (test-bit-position 10 (list 0 3) 1 4 nil 3)
+  (test-bit-position 10 (list 0 3) 1 4 t 3)
+  (test-bit-position 10 (list 0 3 6) 1 10 nil 3)
+  (test-bit-position 10 (list 0 3 6) 1 10 t 6)
+  (test-bit-position 1000 (list 128 700) 20 500 nil 128)
+  (test-bit-position 1000 (list 128 700) 20 500 t 128)
+  (test-bit-position 1000 (list 423 762) 200 800 nil 423)
+  (test-bit-position 1000 (list 423 762) 200 800 t 762)
+  (test-bit-position 1000 (list 298 299) 100 400 nil 298)
+  (test-bit-position 1000 (list 298 299) 100 400 t 299))
+
+(with-test (:name (:bit-position :random-test))
+  (random-test-bit-position 10000))
+

 ;;; success
 ;;; success