Commit 1258638a authored by pfdietz's avatar pfdietz

Began adding tests for conditions and hash tables.

Added tests for env arguments to typep, subtypep, upgraded-array-element-type,
macroexpand, macroexpand-1.
Add more arrays to *universe*, in particular #() which showed a bug
in some named structure predicates in CMUCL.
parent 23202d54
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Jan 28 06:48:19 2003
;;;; Contains: Tests of ASSERT
(in-package :cl-test)
(deftest assert.1
(assert t)
nil)
(deftest assert.2
(assert t ())
nil)
;;; I am assuming that when no places are given to ASSERT,
;;; it doesn't invoke any interactive handler.
(deftest assert.3
(let ((x nil))
(handler-bind
((error #'(lambda (c)
(setq x 17)
(let ((r (find-restart 'continue c)))
(when r (invoke-restart r))))))
(progn
(assert x)
x)))
17)
;;; I don't yet know how to test the interactive version of ASSERT
;;; that is normally invoked when places are given.
;;; Tests of the syntax (at least)
(deftest assert.4
(let (x)
(assert t (x)))
nil)
(deftest assert.5
(let ((x (cons 'a 'b)))
(assert t ((car x) (cdr x))))
nil)
(deftest assert.6
(let ((x (vector 'a 'b 'c)))
(assert t ((aref x 0) (aref x 1) (aref x 2))
"Vector x has value: ~A." x))
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Jan 27 22:36:48 2003
;;;; Contains: Tests of CELL-ERROR-NAME
(in-package :cl-test)
(deftest cell-error-name.1
(handler-case
(eval 'my-unbound-variable)
(cell-error (c) (cell-error-name c)))
my-unbound-variable)
(deftest cell-error-name.2
(handler-case
(eval '(my-undefined-function))
(cell-error (c) (cell-error-name c)))
my-undefined-function)
(deftest cell-error-name.3
(cell-error-name (make-condition 'unbound-variable :name 'x))
x)
(deftest cell-error-name.4
(cell-error-name (make-condition 'undefined-function :name 'f))
f)
(deftest cell-error-name.5
(cell-error-name (make-condition 'unbound-slot :name 's))
s)
;;; Need test raising condition unbound-slot
(deftest cell-error-name.error.1
(classify-error (cell-error-name))
program-error)
(deftest cell-error-name.error.2
(classify-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil))
program-error)
......@@ -1450,7 +1450,6 @@
when (not (boundp s))
collect s)
nil)
;;; Check that all types that are classes name classes.
......@@ -1458,7 +1457,7 @@
;;; a corresponding class with the same proper name as the type.
;;; These type specifiers are listed in Figure 4-8." -- section 4.3.7
(deftest cl-types-that-are-classes-symbols.1
(deftest cl-types-that-are-classes.1
;; Collect class names that violate the condition in the
;; above quotation.
(loop
......@@ -1470,6 +1469,34 @@
collect s)
nil)
(deftest cl-types-that-are-classes.2
;; The same as cl-types-that-are-classes.1
;; with an environment argument
(loop
for s in *cl-types-that-are-classes-symbols*
for c = (find-class s nil nil)
unless (and c
(eq (class-name c) s)
(typep c 'class))
collect s)
nil)
(deftest cl-types-that-are-classes.3
;; The same as cl-types-that-are-classes.1,
;; with an environment argument
(loop
for s in *cl-types-that-are-classes-symbols*
for c = (eval `(macrolet ((%foo (&environment env)
(list 'quote
(find-class ',s nil env))))
(%foo)))
unless (and c
(eq (class-name c) s)
(typep c 'class))
collect s)
nil)
;;; Various error cases for symbol-related functions
(deftest symbolp.error.1
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Mon Jan 27 22:13:25 2003
;;;; Contains: Tests of class CONDITION
(in-package :cl-test)
(deftest condition.1
(notnot-mv (find-class 'condition nil))
t)
(defparameter *allowed-condition-inclusions*
'(
(arithmetic-error error serious-condition condition)
(cell-error error serious-condition condition)
(condition)
(control-error error serious-condition condition)
(division-by-zero arithmetic-error error serious-condition condition)
(end-of-file stream-error error serious-condition condition)
(error serious-condition condition)
(file-error error serious-condition condition)
(floating-point-inexact arithmetic-error error serious-condition condition)
(floating-point-invalid-operation arithmetic-error error serious-condition condition)
(floating-point-overflow arithmetic-error error serious-condition condition)
(floating-point-underflow arithmetic-error error serious-condition condition)
(package-error error serious-condition condition)
(parse-error error serious-condition condition)
(print-not-readable error serious-condition condition)
(program-error error serious-condition condition)
(reader-error parse-error stream-error error serious-condition condition)
(serious-condition condition)
(simple-condition condition)
(simple-error simple-condition error serious-condition condition)
(simple-type-error simple-condition type-error error serious-condition condition)
(simple-warning simple-condition warning condition)
(storage-condition serious-condition condition)
(stream-error error serious-condition condition)
(style-warning warning condition)
(type-error error serious-condition condition)
(unbound-slot cell-error error serious-condition condition)
(unbound-variable cell-error error serious-condition condition)
(undefined-function cell-error error serious-condition condition)
(warning condition)
))
;;; Relationships given in *allowed-condition-inclusions* are the only
;;; subtype relationships allowed on condition types
(deftest condition.2
(loop for (cnd . supers) in *allowed-condition-inclusions*
append (loop for super in supers
unless (subtypep cnd super)
collect (list cnd super)))
nil)
(deftest condition.3
;; Relationships given in *allowed-condition-inclusions* are the only
;; subtype relationships allowed on condition types
(loop for cnds in *allowed-condition-inclusions*
for cnd = (first cnds)
append (loop for super in (set-difference *condition-types* cnds)
when (subtypep cnd super)
collect (list cnd super)))
nil)
......@@ -104,6 +104,11 @@
(load "loop16.lsp")
(load "loop17.lsp")
;;; Tests of conditions
(load "condition.lsp")
(load "cell-error-name.lsp")
(load "assert.lsp")
;;; Tests of conses
(load "cons-test-01.lsp")
......@@ -178,6 +183,12 @@
(load "bit-vector-p.lsp")
(load "simple-bit-vector-p.lsp")
;;; Tests of hash tables
(load "hash-table.lsp")
(load "make-hash-table.lsp")
; More to come
;;; Tests of packages
(load "packages.lsp")
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Jan 26 21:30:42 2003
;;;; Contains: Tests of HASH-TABLE and related interface
(in-package :cl-test)
(deftest hash-table.1
(notnot-mv (find-class 'hash-table))
t)
(deftest hash-table.2
(loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011
#0aNIL #2a((a b)(c d)) #p"foo"
"bar" #\a 3/5 #c(1.0 2.0))
when (typep e 'hash-table)
collect e)
nil)
(deftest hash-table.3
(let ((c (find-class 'hash-table)))
(loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011
#0aNIL #2a((a b)(c d)) #p"foo"
"bar" #\a 3/5 #c(1.0 2.0))
when (typep e c)
collect e))
nil)
(deftest hash-table.4
(notnot-mv (typep (make-hash-table) 'hash-table))
t)
(deftest hash-table.5
(notnot-mv (typep (make-hash-table) (find-class 'hash-table)))
t)
;;;
(deftest hash-table-p.1
(loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011
#0aNIL #2a((a b)(c d)) #p"foo"
"bar" #\a 3/5 #c(1.0 2.0))
when (hash-table-p e)
collect e)
nil)
(deftest hash-table-p.2
(loop for e in *universe*
for p = (typep e 'hash-table)
for q = (hash-table-p e)
always (if p q (not q)))
t)
......@@ -129,3 +129,13 @@
(if (eq y 'a) 1 2))))
(foo a)))
2)
(deftest macrolet.14
(symbol-macrolet ((a b))
(macrolet ((foo (x &environment env)
(let ((y (macroexpand-1 x env)))
(if (eq y 'a) 1 2))))
(foo a)))
2)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Jan 26 21:36:33 2003
;;;; Contains: Tests for MAKE-HASH-TABLE
(in-package :cl-test)
#|
(deftest make-hash-table.1
(let ((ht (make-hash-table)))
(values
(check-values (typep ht 'hash-table))
(notnot (check-values (hash-table-p ht)))
(check-values (hash-table-count ht))
|#
......@@ -40,22 +40,18 @@
warning))
(defvar *condition-objects*
(loop
for tp in *condition-types* append
(handler-case
(list (make-condition tp))
(error () nil))))
(loop for tp in *condition-types* append
(handler-case (list (make-condition tp))
(error () nil))))
(defvar *standard-package-names*
'("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD"))
'("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD"))
(defvar *package-objects*
(loop
for pname in *standard-package-names* append
(handler-case
(let ((pkg (find-package pname)))
(and pkg (list pkg)))
(error () nil))))
(loop for pname in *standard-package-names* append
(handler-case (let ((pkg (find-package pname)))
(and pkg (list pkg)))
(error () nil))))
(defvar *integers*
(remove-duplicates
......@@ -76,6 +72,7 @@
(defvar *floats*
(list
PI
MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT
LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT
LEAST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT
......@@ -157,7 +154,8 @@
do (let ((c (code-char i)))
(when c
(setf (elt s i) c))))
s))))
s)
)))
(defvar *conses*
(list
......@@ -180,9 +178,7 @@
(defvar *booleans* '(nil t))
(defvar *keywords* '(:a :b :|| :|a| :|1234|))
(defvar *uninterned-symbols*
(list '#:nil '#:t '#:foo
#-CMU '#:||
))
(list '#:nil '#:t '#:foo '#:||))
(defvar *cl-test-symbols*
`(,(intern "a" :cl-test)
,(intern "" :cl-test)
......@@ -213,9 +209,11 @@
(defvar *array-dimensions*
(loop
for i from 1 to 8 collect
for i from 0 to 8 collect
(loop for j from 1 to i collect 2)))
(defvar *default-array-target* (make-array '(300)))
(defvar *arrays*
(append
(list (make-array '10))
......@@ -233,6 +231,50 @@
(loop
for d in *array-dimensions*
collect (make-array d :adjustable t))
;; Displaced arrays
(loop
for d in *array-dimensions*
for i from 1
collect (make-array d :displaced-to *default-array-target*
:displaced-index-offset i))
(list
#()
#*
#*00000
#*1010101010101101)
;; Integer arrays
(list
(make-array '(10) :element-type '(integer 0 (256))
:initial-contents '(8 9 10 11 12 1 2 3 4 5))
(make-array '(10) :element-type '(integer -128 (128))
:initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5))
(make-array '(6) :element-type '(integer 0 (#.(ash 1 16)))
:initial-contents '(5 9 100 1312 23432 87))
(make-array '(4) :element-type '(integer 0 (#.(ash 1 28)))
:initial-contents '(100000 231213 8123712 19))
(make-array '(4) :element-type '(integer 0 (#.(ash 1 32)))
:initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000))
(make-array nil :element-type '(integer 0 (256))
:initial-element 14)
(make-array '(2 2) :element-type '(integer 0 (256))
:initial-contents '((34 98)(14 119)))
)
;; Float arrays
(list
(make-array '(5) :element-type 'short-float
:initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0))
(make-array '(5) :element-type 'single-float
:initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0))
(make-array '(5) :element-type 'double-float
:initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0))
(make-array '(5) :element-type 'long-float
:initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0))
)
;; more kinds of arrays here later
))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment