Skip to content
Snippets Groups Projects
Commit 0ac7cdde authored by pfdietz's avatar pfdietz
Browse files

Mostly hash table tests; some minor comment changes in rctest.

parent c4e442d5
No related branches found
No related tags found
No related merge requests found
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Oct 4 09:24:24 2003
;;;; Contains: Aux. functions for testing hash tables
(in-package :cl-test)
(eval-when (:load-toplevel :compile-toplevel :execute)
(compile-and-load "random-aux.lsp"))
(defparameter *hash-table-test-iters* 1000)
(defun test-hash-table-1 (&rest args)
(let ((table (apply #'make-hash-table args))
(test (or (getf args :test) 'eql)))
(assert (member test '(eq eql equal equalp)))
(assert (hash-table-p table))
(assert (typep table 'hash-table))
;; Build a hash table using the arguments in ARGS.
;; Perform *hash-table-test-iters* iterations of
;; random hash table operations
(let* ((universe-vec (coerce *universe* 'vector))
;; (universe-size (length universe-vec))
(mapping nil)
(count 0))
(loop
for i from 0 below *hash-table-test-iters*
do (assert (eql (hash-table-count table) count))
do (assert (let ((size (hash-table-size table)))
(and (integerp size) (>= size 0))))
do
(flet ((%remove-pair
(rpair)
(decf count)
(let ((key (car rpair))
(expected-value (cdr rpair)))
(multiple-value-bind (value present-p)
(gethash key table)
(assert present-p)
(assert (eql expected-value value))
(setf mapping
(remove rpair mapping :count 1 :test 'eq)))
(assert (remhash key table))
(multiple-value-bind (value present-p)
(gethash key table)
(assert (not present-p))
(assert (null value))
))))
(rcase
(1 ;; Insert
(let* ((new-elem (random-from-seq universe-vec))
(pair (assoc new-elem mapping :test test)))
(cond
(pair
(multiple-value-bind
(value present-p)
(gethash new-elem table)
(assert present-p)
(assert (eql (cdr pair) value))
(setf (cdr pair) i
(gethash new-elem table) i)))
(t
(assert
(equal (multiple-value-list (gethash new-elem table))
'(nil nil)))
(incf count)
(push (cons new-elem i) mapping)
(setf (gethash new-elem table) i)))))
(1 ;; Delete element in the set
(when mapping
(%remove-pair (random-from-seq mapping))))
(1 ;; Delete random element from universe
(let* ((key (random-from-seq universe-vec))
(pair (assoc key mapping :test test)))
(cond
(pair (%remove-pair pair))
(t
;; Not present -- check that this is true
(assert (equal (multiple-value-list (gethash key table))
'(nil nil)))
(assert (not (remhash key table)))
(assert (equal (multiple-value-list (gethash key table))
'(nil nil)))))
))
))))))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Nov 28 05:14:25 2003
;;;; Contains: Tests of HASH-TABLE-COUNT
(in-package :cl-test)
(deftest hash-table-count.1
(hash-table-count (make-hash-table))
0)
(deftest hash-table-count.2
(hash-table-count (make-hash-table :test 'eq))
0)
(deftest hash-table-count.3
(hash-table-count (make-hash-table :test 'eql))
0)
(deftest hash-table-count.4
(hash-table-count (make-hash-table :test 'equal))
0)
(deftest hash-table-count.5
(hash-table-count (make-hash-table :test 'equalp))
0)
(deftest hash-table-count.6
(hash-table-count (make-hash-table :test #'eq))
0)
(deftest hash-table-count.7
(hash-table-count (make-hash-table :test #'eql))
0)
(deftest hash-table-count.8
(hash-table-count (make-hash-table :test #'equal))
0)
(deftest hash-table-count.9
(hash-table-count (make-hash-table :test #'equalp))
0)
(deftest hash-table-count.10
(hash-table-count (let ((table (make-hash-table)))
(setf (gethash 'x table) 1)
table))
1)
(deftest hash-table-count.11
(let ((table (make-hash-table)))
(setf (gethash 'x table) 1)
(values (hash-table-count table)
(progn
(remhash 'x table)
(hash-table-count table))))
1 0)
;; This function is mostly tested by calls to test-hash-table-1
(deftest hash-table-count.error.1
(classify-error (hash-table-count))
program-error)
(deftest hash-table-count.error.2
(classify-error (hash-table-count (make-hash-table) nil))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Nov 28 05:47:24 2003
;;;; Contains: Tests for HASH-TABLE-REHASH-SIZE
(in-package :cl-test)
(deftest hash-table-rehash-size.1
(typep* (hash-table-rehash-size (make-hash-table))
'(or (integer 1 *) (float (1.0) *)))
t)
(deftest hash-table-rehash-size.2
(loop for test in '(eq eql equal equalp)
unless (typep* (hash-table-rehash-size (make-hash-table :test test))
'(or (integer 1 *) (float (1.0) *)))
collect test)
nil)
(deftest hash-table-rehash-size.3
(loop for test in '(eq eql equal equalp)
for fn = (symbol-function test)
unless (typep* (hash-table-rehash-size (make-hash-table :test fn))
'(or (integer 1 *) (float (1.0) *)))
collect test)
nil)
(deftest hash-table-rehash-size.error.1
(classify-error (hash-table-rehash-size))
program-error)
(deftest hash-table-rehash-size.error.2
(classify-error (hash-table-rehash-size (make-hash-table) nil))
program-error)
(deftest hash-table-rehash-size.error.3
(loop for x in *mini-universe*
unless (hash-table-p x)
unless (eq (eval `(classify-error (hash-table-rehash-size ',x)))
'type-error)
collect x)
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Nov 28 05:52:52 2003
;;;; Contains: Tests of HASH-TABLE-REHASH-THRESHOLD
(in-package :cl-test)
(deftest hash-table-rehash-threshold.1
(typep* (hash-table-rehash-threshold (make-hash-table))
'(real 0 1))
t)
(deftest hash-table-rehash-threshold.2
(loop for test in '(eq eql equal equalp)
unless (typep* (hash-table-rehash-threshold (make-hash-table :test test))
'(real 0 1))
collect test)
nil)
(deftest hash-table-rehash-threshold.3
(loop for test in '(eq eql equal equalp)
for fn = (symbol-function test)
unless (typep* (hash-table-rehash-threshold (make-hash-table :test fn))
'(real 0 1))
collect test)
nil)
(deftest hash-table-rehash-threshold.error.1
(classify-error (hash-table-rehash-threshold))
program-error)
(deftest hash-table-rehash-threshold.error.2
(classify-error (hash-table-rehash-threshold (make-hash-table) nil))
program-error)
(deftest hash-table-rehash-threshold.error.3
(loop for x in *mini-universe*
unless (hash-table-p x)
unless (eq (eval `(classify-error (hash-table-rehash-threshold ',x)))
'type-error)
collect x)
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Nov 28 05:23:45 2003
;;;; Contains: Tests for HASH-TABLE-SIZE
(in-package :cl-test)
(deftest hash-table-size.error.1
(classify-error (hash-table-size))
program-error)
(deftest hash-table-size.error.2
(classify-error (hash-table-size (make-hash-table) nil))
program-error)
(deftest hash-table-size.error.3
(loop for x in *mini-universe*
unless (hash-table-p x)
unless (eq (eval `(classify-error (hash-table-size ',x)))
'type-error)
collect x)
nil)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Nov 28 05:56:22 2003
;;;; Contains: Tests for HASH-TABLE-TEST
(in-package :cl-test)
(deftest hash-table-test.1
(hash-table-test (make-hash-table))
eql)
(deftest hash-table-test.2
(loop for test in '(eq eql equal equalp)
unless (eq (hash-table-test (make-hash-table :test test)) test)
collect test)
nil)
(deftest hash-table-test.3
(loop for test in '(eq eql equal equalp)
unless (eq (hash-table-test (make-hash-table
:test (symbol-function test)))
test)
collect test)
nil)
(deftest hash-table-test.4
(loop for test in '(eq eql equal equalp)
unless (eq (hash-table-test (make-hash-table
:test (eval `(function ,test))))
test)
collect test)
nil)
;;; Error cases
(deftest hash-table-test.error.1
(classify-error (hash-table-test))
program-error)
(deftest hash-table-test.error.2
(classify-error (hash-table-test (make-hash-table) nil))
program-error)
(deftest hash-table-test.error.3
(loop for x in *mini-universe*
unless (hash-table-p x)
unless (eq (eval `(classify-error (hash-table-test ',x)))
'type-error)
collect x)
nil)
(compile-and-load "hash-table-aux.lsp")
(load "hash-table.lsp") (load "hash-table.lsp")
(load "make-hash-table.lsp") (load "make-hash-table.lsp")
(load "hash-table-p.lsp") (load "hash-table-p.lsp")
\ No newline at end of file (load "hash-table-count.lsp")
(load "hash-table-size.lsp")
(load "hash-table-rehash-size.lsp")
(load "hash-table-rehash-threshold.lsp")
(load "hash-table-test.lsp")
(load "gethash.lsp")
...@@ -5,6 +5,9 @@ ...@@ -5,6 +5,9 @@
(in-package :cl-test) (in-package :cl-test)
;; (eval-when (:load-toplevel :compile-toplevel :execute)
;; (compile-and-load "hash-table-aux.lsp"))
(deftest make-hash-table.1 (deftest make-hash-table.1
(let ((ht (make-hash-table))) (let ((ht (make-hash-table)))
(values (values
...@@ -93,6 +96,153 @@ ...@@ -93,6 +96,153 @@
(hash-table-count ht))) (hash-table-count ht)))
t t 0) t t 0)
(deftest make-hash-table.12
(let ((ht (make-hash-table :rehash-size 1)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.13
(let ((ht (make-hash-table :rehash-size 1000)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.14
(let ((ht (make-hash-table :rehash-size (+ 1.0f0 single-float-epsilon))))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.15
(let ((ht (make-hash-table :rehash-size 2.0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.16
(let ((ht (make-hash-table :rehash-threshold 0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.17
(let ((ht (make-hash-table :rehash-threshold 0.0s0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.18
(let ((ht (make-hash-table :rehash-threshold 0.0f0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.19
(let ((ht (make-hash-table :rehash-threshold 0.0d0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.20
(let ((ht (make-hash-table :rehash-threshold 0.0l0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.21
(let ((ht (make-hash-table :rehash-threshold 1/2)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.22
(let ((ht (make-hash-table :rehash-threshold 0.1s0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.23
(let ((ht (make-hash-table :rehash-threshold 0.2f0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.24
(let ((ht (make-hash-table :rehash-threshold 0.8d0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.25
(let ((ht (make-hash-table :rehash-threshold 0.99f0)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.26
(let ((ht (make-hash-table :rehash-threshold least-positive-short-float)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.27
(let ((ht (make-hash-table :rehash-threshold least-positive-single-float)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.28
(let ((ht (make-hash-table :rehash-threshold least-positive-double-float)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
(deftest make-hash-table.29
(let ((ht (make-hash-table :rehash-threshold least-positive-long-float)))
(values
(notnot (typep ht 'hash-table))
(notnot (hash-table-p ht))
(hash-table-count ht)))
t t 0)
...@@ -104,4 +254,4 @@ ...@@ -104,4 +254,4 @@
\ No newline at end of file
...@@ -12,6 +12,8 @@ ...@@ -12,6 +12,8 @@
for those classes.") for those classes.")
(defgeneric prototype (class) (defgeneric prototype (class)
;; Map a class to a prototype instance of the class. Cache using
;; *prototype-class-table*.
(:method ((class standard-class) &aux (name (class-name class))) (:method ((class standard-class) &aux (name (class-name class)))
(or (gethash name *prototype-class-table*) (or (gethash name *prototype-class-table*)
(setf (gethash name *prototype-class-table*) (setf (gethash name *prototype-class-table*)
...@@ -19,6 +21,10 @@ ...@@ -19,6 +21,10 @@
(:method ((class symbol)) (:method ((class symbol))
(prototype (find-class class)))) (prototype (find-class class))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generators are objects that are used to create random instances.
(defclass generator () ()) (defclass generator () ())
(defclass composite-generator (generator) (defclass composite-generator (generator)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment