X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fseq.impure.lisp;h=9616cde3c85421f8af76bb9863671c6dcc9e9988;hb=22c592cbf7e81e78ceaef80d1c15ad7a7fc3b40a;hp=2df75d13ee736d56b848f4e4299f2d2382fb5570;hpb=41cb424785ec6daf0263acb1a6a8af9d41708990;p=sbcl.git diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 2df75d1..9616cde 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -21,58 +21,84 @@ (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) - (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)))) - (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) @@ -109,6 +135,12 @@ (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 #() @@ -303,6 +335,24 @@ ;; ... 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) @@ -351,10 +401,8 @@ 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 (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)))