From 5da45f2f46c146177c3c7de593565becca8370ba Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Wed, 12 Feb 2003 02:25:41 +0000
Subject: [PATCH] Added the correct tests for TYPECASE, and some tests for
 AREF.

---
 ansi-tests/ansi-aux.lsp |   2 +
 ansi-tests/aref.lsp     | 144 ++++++++++++++++++++++++++++++++++++++++
 ansi-tests/gclload2.lsp |   1 +
 ansi-tests/typecase.lsp |  10 +++
 4 files changed, 157 insertions(+)
 create mode 100644 ansi-tests/aref.lsp

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index 84951a2a..1e0eec7e 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 00000000..d1a4a717
--- /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 6f13155f..56427a13 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 f3185313..8c83cda9 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
-- 
GitLab