first cut at testing unicode normalization

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

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 9684221..e497115 100644 (file)
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -13,65 +13,90 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 

+(load "test-util.lisp")

 (load "assertoid.lisp")
 
 (defpackage :seq-test
 (load "assertoid.lisp")
 
 (defpackage :seq-test

-  (:use :cl :assertoid))
+  (:use :cl :assertoid :test-util))

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

@@ -162,7 +187,23 @@
     (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
     (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
     (null (find-if-not #'plusp seq))
     (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
     (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
     (null (find-if-not #'plusp seq))

-    (eql 0 (position-if-not #'evenp seq))))
+    (eql 0 (position-if-not #'evenp seq))
+    (eql 0 (search #(1) seq))
+    (eql 1 (search #(4 5) seq :key 'oddp))
+    (eql 1 (search #(-2) seq :test (lambda (a b) (= (- a) b))))
+    (eql 4 (search #(1) seq :start2 1))
+    (null (search #(3) seq :start2 3))
+    (eql 2 (search #(3) seq :start2 2))
+    (eql 0 (search #(1 2) seq))
+    (null (search #(2 1 3) seq))
+    (eql 0 (search #(0 1 2 4) seq :start1 1 :end1 3))
+    (eql 3 (search #(0 2 1 4) seq :start1 1 :end1 3))
+    (eql 4 (search #(1) seq :from-end t))
+    (eql 0 (search #(1 2) seq :from-end t))
+    (null (search #(1 2) seq :from-end t :start2 1))
+    (eql 0 (search #(0 1 2 4) seq :from-end t :start1 1 :end1 3))
+    (eql 3 (search #(0 2 1 4) seq :from-end t :start1 1 :end1 3))
+    (null (search #(2 1 3) seq :from-end t))))

 (for-every-seq "string test"
   '((null (find 0 seq))
     (null (find #\D seq :key #'char-upcase))
 (for-every-seq "string test"
   '((null (find 0 seq))
     (null (find #\D seq :key #'char-upcase))

@@ -361,15 +402,18 @@
   (svref x 0))
 (assert (raises-error? (svrefalike #*0) type-error))
 \f
   (svref x 0))
 (assert (raises-error? (svrefalike #*0) type-error))
 \f

-;;; checks for uniform bounding index handling under SAFETY 3 code.
+;;; checks for uniform bounding index handling.
+;;;
+;;; This used to be SAFETY 3 only, but bypassing these checks with
+;;; above-zero speed when SPEED > SAFETY is not The SBCL Way.

 ;;;
 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
 ;;; an absolute age trying to compile it.
 (defmacro sequence-bounding-indices-test (&body body)
   `(progn
 ;;;
 ;;; KLUDGE: not all in one big form because that causes SBCL to spend
 ;;; an absolute age trying to compile it.
 (defmacro sequence-bounding-indices-test (&body body)
   `(progn

-    (locally
+     (locally

     ;; See Issues 332 [and 333(!)] in the CLHS
     ;; See Issues 332 [and 333(!)] in the CLHS

-    (declare (optimize (safety 3)))
+    (declare (optimize (speed 3) (safety 1)))

     (let ((string (make-array 10
                               :fill-pointer 5
                               :initial-element #\a
     (let ((string (make-array 10
                               :fill-pointer 5
                               :initial-element #\a

@@ -385,7 +429,7 @@
           ,@(cdr body))))
     (locally
       ;; See Issues 332 [and 333(!)] in the CLHS
           ,@(cdr body))))
     (locally
       ;; See Issues 332 [and 333(!)] in the CLHS

-      (declare (optimize (safety 3)))
+      (declare (optimize (speed 3) (safety 1)))

       (let ((string (make-array 10
                                 :fill-pointer 5
                                 :initial-element #\a
       (let ((string (make-array 10
                                 :fill-pointer 5
                                 :initial-element #\a

@@ -515,7 +559,9 @@
 (sequence-bounding-indices-test
  (format t "~&/Function PARSE-NAMESTRING")
  (setf (fill-pointer string) 10)
 (sequence-bounding-indices-test
  (format t "~&/Function PARSE-NAMESTRING")
  (setf (fill-pointer string) 10)

- (setf (subseq string 0 10) "/dev/ /tmp")
+ (setf (subseq string 0 10)
+       #-win32 "/dev/ /tmp"
+       #+win32 "C:/   NUL")

  (setf (fill-pointer string) 5)
  (assert (truename (parse-namestring string nil *default-pathname-defaults*
                                      :start 0 :end 5)))
  (setf (fill-pointer string) 5)
  (assert (truename (parse-namestring string nil *default-pathname-defaults*
                                      :start 0 :end 5)))

@@ -936,7 +982,8 @@
                                      standard bashed)
               ;; fill vectors
               ;; a) the standard slow way
                                      standard bashed)
               ;; fill vectors
               ;; a) the standard slow way

-              (fill standard c :start offset :end (+ offset n))
+              (locally (declare (notinline fill))
+                (fill standard c :start offset :end (+ offset n)))

               ;; b) the blazingly fast way
               (let ((value (loop for i from 0 by bitsize
                                  until (= i sb-vm:n-word-bits)
               ;; b) the blazingly fast way
               (let ((value (loop for i from 0 by bitsize
                                  until (= i sb-vm:n-word-bits)

@@ -990,13 +1037,219 @@
                      bashed-dst)
              (return-from test-copy-bashing nil))))))))
 
                      bashed-dst)
              (return-from test-copy-bashing nil))))))))
 

+;; Too slow for the interpreter
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))

 (loop for i = 1 then (* i 2) do
 (loop for i = 1 then (* i 2) do

-     ;; the bare '32' here is fairly arbitrary; '8' provides a good
-     ;; range of lengths over which to fill and copy, which should tease
-     ;; out most errors in the code (if any exist).  (It also makes this
-     ;; part of the test suite finish reasonably quickly.)
-     (assert (test-fill-bashing i 32 8))
-     (assert (test-copy-bashing i 32 8))
+     ;; the bare '13' here is fairly arbitrary, except that it's been
+     ;; reduced from '32', which made the tests take aeons; '8' provides
+     ;; a good range of lengths over which to fill and copy, which
+     ;; should tease out most errors in the code (if any exist).  (It
+     ;; also makes this part of the test suite finish reasonably
+     ;; quickly.)
+     (assert (time (test-fill-bashing i 13 8)))
+     (assert (time (test-copy-bashing i 13 8)))

      until (= i sb-vm:n-word-bits))
      until (= i sb-vm:n-word-bits))

+
+(defun test-inlined-bashing (bitsize)
+  ;; We have to compile things separately for each bitsize so the
+  ;; compiler will work out the array type and trigger the REPLACE
+  ;; transform.
+  (let ((lambda-form
+         `(lambda ()
+            (let* ((n-elements-per-word ,(truncate sb-vm:n-word-bits bitsize))
+                   (size (* 3 n-elements-per-word))
+                   (standard-dst (make-array size :element-type '(unsigned-byte ,bitsize)))
+                   (bashed-dst (make-array size :element-type '(unsigned-byte ,bitsize)))
+                   (source (make-array size :element-type '(unsigned-byte ,bitsize))))
+              (declare (type (simple-array (unsigned-byte ,bitsize) (*))
+                             source standard-dst bashed-dst))
+              (do ((i 0 (1+ i))
+                   (offset n-elements-per-word (1+ offset)))
+                  ((>= offset (* 2 n-elements-per-word)) t)
+                (dolist (c (fill-bytes-for-testing ,bitsize))
+                  (fill-with-known-value (mod (lognot c) (ash 1 ,bitsize)) size
+                                         source standard-dst bashed-dst)
+                  ;; fill with test-data
+                  (fill source c :start offset :end (+ offset n-elements-per-word))
+                  ;; copy filled data to test vectors
+                  ;;
+                  ;; a) the slow way (which is actually fast, since this
+                  ;; should be transformed into UB*-BASH-COPY)
+                  (replace standard-dst source
+                           :start1 (- offset n-elements-per-word i)
+                           :start2 (- offset n-elements-per-word i)
+                           :end1 offset :end2 offset)
+                  ;; b) the fast way--we fold the
+                  ;; :START{1,2} arguments above ourselves
+                  ;; to trigger the REPLACE transform
+                  (replace bashed-dst source
+                           :start1 0 :start2 0 :end1 offset :end2 offset)
+                  ;; check for errors
+                  (when (or (mismatch standard-dst bashed-dst)
+                            ;; trigger COPY-SEQ transform
+                            (mismatch (copy-seq standard-dst) bashed-dst)
+                            ;; trigger SUBSEQ transform
+                            (mismatch (subseq standard-dst (- offset n-elements-per-word i))
+                                      bashed-dst))
+                    (format t "Test with target-offset ~A, source-offset ~A, fill ~A, and length ~A failed.~%"
+                            0 0 c offset)
+                    (format t "Mismatch:~% correct ~A~% actual  ~A~%"
+                            standard-dst
+                            bashed-dst)
+                    (return-from nil nil))))))))
+    (funcall (compile nil lambda-form))))
+
+#+#.(cl:if (cl:eq sb-ext:*evaluator-mode* :compile) '(and) '(or))
+(loop for i = 1 then (* i 2) do
+      (assert (test-inlined-bashing i))
+      until (= i sb-vm:n-word-bits))

 \f
 \f

+;;; tests from the Sacla test suite via Eric Marsden, 2007-05-07
+(remove-duplicates (vector 1 2 2 1) :test-not (lambda (a b) (not (= a b))))
+
+(delete-duplicates (vector #\a #\b #\c #\a)
+                   :test-not (lambda (a b) (not (char-equal a b))))
+
+;;; FILL on lists
+(let ((l (list 1 2 3)))
+  (assert (eq l (fill l 0 :start 1 :end 2)))
+  (assert (equal l '(1 0 3)))
+  (assert (eq l (fill l 'x :start 2 :end 3)))
+  (assert (equal l '(1 0 x)))
+  (assert (eq l (fill l 'y :start 1)))
+  (assert (equal l '(1 y y)))
+  (assert (eq l (fill l 'z :end 2)))
+  (assert (equal l '(z z y)))
+  (assert (eq l (fill l 1)))
+  (assert (equal l '(1 1 1)))
+  (assert (raises-error? (fill l 0 :start 4)))
+  (assert (raises-error? (fill l 0 :end 4)))
+  (assert (raises-error? (fill l 0 :start 2 :end 1))))
+
+;;; Both :TEST and :TEST-NOT provided
+(with-test (:name :test-and-test-not-to-adjoin)
+  (let* ((wc 0)
+         (fun
+          (handler-bind (((and warning (not style-warning))
+                          (lambda (w) (incf wc))))
+            (compile nil `(lambda (item test test-not) (adjoin item '(1 2 3 :foo)
+                                                               :test test
+                                                               :test-not test-not))))))
+    (assert (= 1 wc))
+    (assert (eq :error
+                (handler-case
+                    (funcall fun 1 #'eql (complement #'eql))
+                  (error ()
+                    :error))))))
+\f
+;;; tests of deftype types equivalent to STRING or SIMPLE-STRING
+(deftype %string () 'string)
+(deftype %simple-string () 'simple-string)
+(deftype string-3 () '(string 3))
+(deftype simple-string-3 () '(simple-string 3))
+
+(with-test (:name :user-defined-string-types-map-etc)
+  (dolist (type '(%string %simple-string string-3 simple-string-3))
+    (assert (string= "foo" (coerce '(#\f #\o #\o) type)))
+    (assert (string= "foo" (map type 'identity #(#\f #\o #\o))))
+    (assert (string= "foo" (merge type '(#\o) '(#\f #\o) 'char<)))
+    (assert (string= "foo" (concatenate type '(#\f) "oo")))
+    (assert (string= "ooo" (make-sequence type 3 :initial-element #\o)))))
+(with-test (:name :user-defined-string-types-map-etc-error)
+  (dolist (type '(string-3 simple-string-3))
+    (assert (raises-error? (coerce '(#\q #\u #\u #\x) type)))
+    (assert (raises-error? (map type 'identity #(#\q #\u #\u #\x))))
+    (assert (raises-error? (merge type '(#\q #\x) "uu" 'char<)))
+    (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