diff --git a/tests/sequences.lisp b/tests/sequences.lisp index 94f445c..41de8ca 100644 --- a/tests/sequences.lisp +++ b/tests/sequences.lisp @@ -3,7 +3,34 @@ (def-suite sequences :in serapeum) (in-suite sequences) -;;; TODO Actually test with extensible sequences. +;;; Borrowed from the test suite of split-sequence. TODO: also test on +;;; ABCL and Clasp. +#+sbcl +(progn + (defclass eseq (standard-object sequence) + ((actual-seq :type list :initarg :actual-seq :initform nil + :accessor actual-seq)) + (:documentation "Extended sequence type in SBCL")) + (defmethod sb-sequence:length ((s eseq)) + (length (actual-seq s))) + (defmethod sb-sequence:elt ((s eseq) index) + (elt (actual-seq s) index)) + (defmethod (setf sb-sequence:elt) (v (s eseq) index) + (setf (elt (actual-seq s) index) v)) + (defmethod sb-sequence:adjust-sequence ((s eseq) len &rest args) + (setf (actual-seq s) + (apply #'sb-sequence:adjust-sequence (actual-seq s) len args))) + (defmethod sb-sequence:make-sequence-like ((s eseq) len &rest args) + (make-instance 'eseq :actual-seq (apply #'sb-sequence:make-sequence-like + (actual-seq s) len args))) + (defmethod print-object ((s eseq) stream) + (print-unreadable-object (s stream :type t) + (format stream "~a" (actual-seq s)))) + (defun eseq (&rest args) + (make 'eseq :actual-seq args))) +#-sbcl +(defun eseq (&rest args) args) + (test single ;; This is too trivial to really need a test, but it also serves a @@ -18,21 +45,30 @@ (is (not (single #()))) (is (single #(t))) - (is (not (single #(t t))))) + (is (not (single #(t t)))) + + (is (not (single (eseq)))) + (is (single (eseq t))) + (is (not (single (eseq t t))))) (test only-elt (signals error (only-elt '())) (signals error (only-elt #())) + (signals error + (only-elt (eseq))) (signals error (only-elt '(1 . 2))) (signals error (only-elt '(1 2))) (signals error (only-elt #(1 2))) + (signals error + (only-elt (eseq 1 2))) (is (eql 1 (only-elt '(1)))) - (is (eql 1 (only-elt #(1))))) + (is (eql 1 (only-elt #(1)))) + (is (eql 1 (only-elt (eseq 1))))) (test scan (is (equal '() (scan #'+ '()))) @@ -88,6 +124,12 @@ (finishes (assort (coerce #(1 2 3) 'simple-vector))) (finishes (assort (coerce #(1 2 3) 'simple-vector)) :hash t)) +(test assort-eseq + (finishes (assort (eseq 1 2 3))) + (finishes (assort (eseq 1 2 3))) + (is (seq= (assort (eseq 1 2 1 2 1 2) :test #'<=) + '((1 1) (2 2 1 2))))) + (test runs (is (equal '((1 2) (3 4 5 6 11 12 13)) (runs '(1 2 3 4 5 6 11 12 13) :key (rcurry #'< 3)))) @@ -99,6 +141,8 @@ (test runs-compare-first (is (seq= (runs #(10 2 3 10 4 5) :test #'>) (runs '(10 2 3 10 4 5) :test #'>))) + (is (seq= (runs (eseq 10 2 3 10 4 5) :test #'>) + (runs '(10 2 3 10 4 5) :test #'>))) (is (seq= (runs #(10 2 3 10 4 5) :test #'> :count 0) (runs '(10 2 3 10 4 5) :test #'> :count 0))) (is (seq= (runs #(10 2 3 10 4 5) :test #'> :count 1) @@ -113,6 +157,7 @@ (test runs-count (is (null (runs '() :count 0))) (is (emptyp (runs #() :count 0))) + (is (eql (length (runs (eseq) :count 0)) 0)) (is (equal '((head) (tail tail)) (runs '(head tail tail head head tail) :count 2))) (for-all ((i (lambda () (random 100))) @@ -126,6 +171,7 @@ (is (equal '(()) (runs '() :compare-last t))) (is (equalp '((1)) (runs '(1) :compare-last t))) (is (equalp '(#()) (runs #() :compare-last t))) + (is (seq= (list (eseq)) (runs (eseq) :compare-last t))) (is (equalp '(#(1)) (runs #(1) :compare-last t))) (is (seq= (runs #(10 2 3 2 1) :test #'> :compare-last t) (runs '(10 2 3 2 1) :test #'> :compare-last t) @@ -135,7 +181,8 @@ (is (equal '((a b) (c d) (e)) (batches '(a b c d e) 2))) (is (equal '("ab" "cd" "e") (batches "abcde" 2))) (is (equal '("a") (batches "abc" 2 :end 1))) - (is (equal '((a)) (batches '(a b c) 2 :end 1)))) + (is (equal '((a)) (batches '(a b c) 2 :end 1))) + (is (seq= (list (eseq 'a 'b) (eseq 'c 'd)) (batches (eseq 'a 'b 'c 'd) 2)))) (test batches-even (signals error @@ -161,6 +208,7 @@ (test length< (is (length< #() 1)) + (is (length< (eseq) 1)) (is (length< '(1) 2)) (is (not (length< '(1 2) 2))) (is (not (length< '(1 2 3) 2)))) @@ -303,7 +351,8 @@ (test deltas (is (equal '(4 5 -14 6 1) (deltas '(4 9 -5 1 2)))) - (is (equal '(4 5 -14 6 1) (deltas #(4 9 -5 1 2))))) + (is (equal '(4 5 -14 6 1) (deltas #(4 9 -5 1 2)))) + (is (seq= '(4 5 -14 6 1) (deltas (eseq 4 9 -5 1 2))))) (test intersperse (is (null (intersperse 'x '()))) @@ -359,6 +408,7 @@ (is (equal '(13 13 13) (repeat-sequence '(13) 3))) (is (equal '("13" "13" "13") (repeat-sequence '("13") 3))) (is (vector= #(13 13 13) (repeat-sequence #(13) 3))) + (is (seq= (eseq 13 13 13) (repeat-sequence (eseq 13) 3))) ;; 0 repetitions. (is (null (repeat-sequence '(x y z) 0))) (is (equal "" (repeat-sequence "foo" 0))) @@ -397,7 +447,8 @@ (is (equal " world" (drop-prefix '(#\h #\e #\l #\l #\o) "hello world"))) (is (equal " world" (drop-prefix #(#\h #\e #\l #\l #\o) "hello world"))) (is (equalp #(1 2 3) (drop-prefix #(0) #(0 1 2 3)))) - (is (equalp #(1 2 3) (drop-prefix '(0) #(0 1 2 3))))) + (is (equalp #(1 2 3) (drop-prefix '(0) #(0 1 2 3)))) + (is (seq= #(1 2 3) (drop-prefix '(0) (eseq 0 1 2 3))))) (test ensure-prefix (is (equal "x" (ensure-prefix "x" ""))) @@ -816,6 +867,7 @@ (test null-if-empty (is (null (null-if-empty nil))) (is (null (null-if-empty #()))) + (is (null (null-if-empty (eseq)))) (is (null (null-if-empty ""))) (is (null (null-if-empty (make-octet-vector 0)))) (is (null (null-if-empty (make-array 0 :element-type 'bit))))