X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fseq.impure.lisp;h=4ed1cf497cc791fcd80ce8ba4116d6f969d793a6;hb=a96369c72588c5457d71d6aaea35f2c450b19ef5;hp=03d612ab62126424a62c5b837472256c12bdc6b3;hpb=d1151f185f19fbd4067bddc84b7d45bebf990f6f;p=sbcl.git

diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp
index 03d612a..4ed1cf4 100644
--- a/tests/seq.impure.lisp
+++ b/tests/seq.impure.lisp
@@ -261,14 +261,80 @@
     (assert-type-error (concatenate '(string 6) "foo" " " "bar"))
     (assert (string= (concatenate '(string 6) "foo" #(#\b #\a #\r)) "foobar"))
     (assert-type-error (concatenate '(string 7) "foo" #(#\b #\a #\r))))
-  ;; SIMPLE-ARRAY isn't allowed as a vector type specifier
+  ;; Non-VECTOR ARRAY types aren't allowed as vector type specifiers.
   (locally
-      (declare (optimize safety))
+    (declare (optimize safety))
     (assert-type-error (concatenate 'simple-array "foo" "bar"))
     (assert-type-error (map 'simple-array #'identity '(1 2 3)))
+    (assert (equalp #(11 13)
+		    (map '(simple-array fixnum (*)) #'+ '(1 2 3) '(10 11))))
     (assert-type-error (coerce '(1 2 3) 'simple-array))
+    (assert-type-error (merge 'simple-array '(1 3) '(2 4) '<))
+    (assert (equalp #(3 2 1) (coerce '(3 2 1) '(vector fixnum))))
+    (assert-type-error (map 'array #'identity '(1 2 3)))
+    (assert-type-error (map '(array fixnum) #'identity '(1 2 3)))
+    (assert (equalp #(1 2 3) (coerce '(1 2 3) '(vector fixnum))))
     ;; but COERCE has an exemption clause:
-    (assert (string= "foo" (coerce "foo" 'simple-array)))))
+    (assert (string= "foo" (coerce "foo" 'simple-array)))
+    ;; ... though not in all cases.
+    (assert-type-error (coerce '(#\f #\o #\o) 'simple-array))))
+
+;;; 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)
+(assert (equal '(1 2 3 4) (merge 'list-typeoid '(1 3) '(2 4) '<)))
+;;; and also with types that weren't precicely LIST
+(assert (equal '(1 2 3 4) (merge 'cons '(1 3) '(2 4) '<)))
+
+;;; but wait, there's more! The NULL and CONS types also have implicit
+;;; length requirements:
+(macrolet ((assert-type-error (form)
+	     `(assert (typep (nth-value 1 (ignore-errors ,form)) 
+			     'type-error))))
+  (locally
+      (declare (optimize safety))
+    ;; MAKE-SEQUENCE
+    (assert-type-error (make-sequence 'cons 0))
+    (assert-type-error (make-sequence 'null 1))
+    ;; KLUDGE: I'm not certain that this test actually tests for what
+    ;; it should test, in that the type deriver and optimizers might
+    ;; be too smart for the good of an exhaustive test system.
+    ;; However, it makes me feel good.  -- CSR, 2002-10-18
+    (assert (null (make-sequence 'null 0)))
+    (assert (= (length (make-sequence 'cons 3)) 3))
+    ;; and NIL is not a valid type for MAKE-SEQUENCE
+    (assert-type-error (make-sequence 'nil 0))
+    ;; COERCE
+    (assert-type-error (coerce #(1) 'null))
+    (assert-type-error (coerce #() 'cons))
+    (assert (null (coerce #() 'null)))
+    (assert (= (length (coerce #(1) 'cons)) 1))
+    (assert-type-error (coerce #() 'nil))
+    ;; MERGE
+    (assert-type-error (merge 'null '(1 3) '(2 4) '<))
+    (assert-type-error (merge 'cons () () '<))
+    (assert (null (merge 'null () () '<)))
+    (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4))
+    (assert-type-error (merge 'nil () () '<))
+    ;; CONCATENATE
+    (assert-type-error (concatenate 'null '(1) "2"))
+    (assert-type-error (concatenate 'cons #() ()))
+    (assert (null (concatenate 'null () #())))
+    (assert (= (length (concatenate 'cons #() '(1) "2 3")) 4))
+    (assert-type-error (concatenate 'nil '(3)))
+    ;; FIXME: tests for MAP to come when some brave soul implements
+    ;; the analogous type checking for MAP/%MAP.
+    ))
+
+;;; ELT should signal an error of type TYPE-ERROR if its index
+;;; argument isn't a valid sequence index for sequence:
+(defun test-elt-signal (x)
+  (elt x 3))
+(multiple-value-bind (result error)
+    (ignore-errors (test-elt-signal "foo"))
+  (assert (null result))
+  (assert (typep error 'type-error)))
+(assert (eql (test-elt-signal "foob") #\b))
 
 ;;; success
 (quit :unix-status 104)