diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 84951a2a2582371acb17d35e44ded7aff5b4bfe6..1e0eec7e7b1732c64967362d87e37fdbaa9eac4b 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -1374,3 +1374,5 @@ the condition to go uncaught if it cannot be classified." (defun with-package-iterator-all (packages) (test-with-package-iterator packages :internal :external :inherited)) + +(deftype otherwise () nil) ;; used in testing TYPECASE diff --git a/ansi-tests/aref.lsp b/ansi-tests/aref.lsp new file mode 100644 index 0000000000000000000000000000000000000000..d1a4a7176dc7b2c25270cbea3d21113f43777bc7 --- /dev/null +++ b/ansi-tests/aref.lsp @@ -0,0 +1,144 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Feb 11 17:33:24 2003 +;;;; Contains: Tests for AREF + +(in-package :cl-test) + +;;; AREF is also tested in many other places + +(deftest aref.1 + (aref #0aT) + T) + +(deftest aref.2 + (aref #(1 2 3 4) 2) + 3) + +(deftest aref.3 + (aref #2a((a b c d)(e f g h)) 1 2) + g) + +(deftest aref.4 + (loop for i from 0 below 6 collect (aref "abcdef" i)) + (#\a #\b #\c #\d #\e #\f)) + +(deftest aref.5 + (let ((a (make-array '(2 3) :element-type 'base-char + :initial-contents '("abc" "def")))) + (loop for i below 2 + collect (loop for j below 3 + collect (aref a i j)))) + ((#\a #\b #\c) + (#\d #\e #\f))) + +(deftest aref.6 + (loop for i below 10 collect (aref #*1101100010 i)) + (1 1 0 1 1 0 0 0 1 0)) + +(deftest aref.7 + (let ((a (make-array '(2 5) :element-type 'bit + :initial-contents '((1 1 0 0 1) + (0 1 0 1 0))))) + (loop for i below 2 + collect (loop for j below 5 + collect (aref a i j)))) + ((1 1 0 0 1) + (0 1 0 1 0))) + +;;; Order of argument evaluation + +(deftest aref.8 + (let ((i 0) x y (a #(a b c d))) + (values + (aref (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 2)) + i x y)) + c 2 1 2) + +(deftest aref.9 + (let ((i 0) x y z (a #2a((a b c)(d e f)))) + (values + (aref (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 1) + (progn (setf z (incf i)) 2)) + i x y z)) + f 3 1 2 3) + + +;;; Setf of aref + +(deftest setf-aref.1 + (let ((a (copy-seq #(1 2 3 4)))) + (values + (setf (aref a 2) 'z) + a)) + z + #(1 2 z 4)) + +(deftest setf-aref.2 + (let ((a (make-array nil :initial-element 1))) + (values + (setf (aref a) 'z) + a)) + z #0az) + +(deftest setf-aref.3 + (let ((a (make-array '(2 3) :initial-element 'a))) + (values + (setf (aref a 0 1) 'z) + a)) + z + #2a((a z a)(a a a))) + +(deftest setf-aref.4 + (let ((a (copy-seq "abcd"))) + (values + (setf (aref a 0) #\z) + a)) + #\z + "zbcd") + +(deftest setf-aref.5 + (let ((a (copy-seq #*0011))) + (values + (setf (aref a 0) 1) + a)) + 1 + #*1011) + +(deftest setf-aref.6 + (let ((a (make-array '(2 3) :initial-element #\a :element-type 'base-char))) + (values + (setf (aref a 0 1) #\z) + a)) + #\z + #2a((#\a #\z #\a)(#\a #\a #\a))) + +(deftest setf-aref.7 + (let ((a (make-array '(2 3) :initial-element 1 :element-type 'bit))) + (values + (setf (aref a 0 1) 0) + a)) + 0 + #2a((1 0 1)(1 1 1))) + +(deftest setf-aref.8 + (let ((i 0) x y z (a (copy-seq #(a b c d)))) + (values + (setf (aref (progn (setf x (incf i)) a) + (progn (setf y (incf i)) 2)) + (progn (setf z (incf i)) 'z)) + a + i x y z)) + z #(a b z d) 3 1 2 3) + +;;; To add: aref on displaced arrays, arrays with fill pointers, etc. + +(deftest aref.error.1 + (classify-error (aref)) + program-error) + +(deftest aref.error.2 + (classify-error (funcall #'aref)) + program-error) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index 6f13155f14083046b28ec151397d41627ee01fc4..56427a138bdfe9ea46228cf755a6de2d2a1644af 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -140,6 +140,7 @@ ;;; Tests on arrays (compile-and-load "array-aux.lsp") +(load "aref.lsp") (load "array.lsp") (load "array-t.lsp") (load "array-as-class.lsp") diff --git a/ansi-tests/typecase.lsp b/ansi-tests/typecase.lsp index f318531331668d5447ee3c1546b28b5a91289e57..8c83cda9f31883f3bb6cbc1caf2c28da8b1882da 100644 --- a/ansi-tests/typecase.lsp +++ b/ansi-tests/typecase.lsp @@ -64,3 +64,13 @@ (deftest typecase.14 (typecase 1 (symbol 'a) (otherwise)) nil) + +;;; (deftype otherwise () nil) + +(deftest typecase.15 + (typecase 'foo (otherwise :wrong) (t :right)) + :right) + +(deftest typecase.16 + (typecase 'foo (otherwise :wrong) (symbol :right) (t :wrong2)) + :right) \ No newline at end of file