Version 1.102 (other changes not in last commit)

[kmrcl.git] / tests.lisp

diff --git a/tests.lisp b/tests.lisp
index 0b0daa2d4a709c92720a79a9234a1b3d2b8f6019..fb6f977cc5c63481c8e242eb4552aebafa854f11 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -1,4 +1,4 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: kmrcl-tests -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
@@ -7,9 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
-;;;; $Id$
-;;;;
-;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2010 by Kevin M. Rosenberg
 ;;;;
 ;;;; *************************************************************************
 
@@ -438,7 +436,53 @@
 
 (deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134")
 
- ;;; MOP Testing
+;;; Binary tree search tests
+
+(defvar *btree-vector*)
+
+(defun init-btree-vector (len)
+  (make-random-state t)
+  (setq *btree-vector* (make-array (list len)
+                                   :element-type 'fixnum
+                                   :initial-element 0))
+  (dotimes (i (length *btree-vector*))
+    (setf (aref *btree-vector* i) (random most-positive-fixnum)))
+  (setq *btree-vector* (sort *btree-vector* #'<)))
+
+(defun test-btree-vector (len)
+  (init-btree-vector len)
+  (dotimes (i (length *btree-vector*) t)
+    (let ((stored (aref *btree-vector* i)))
+      (multiple-value-bind (pos value last-pos count)
+          (sorted-vector-find stored *btree-vector*)
+        (declare (ignore last-pos))
+        (when (or (not (eql i pos)) (not (eql stored value)))
+          (format t "~&Error: btree value ~D at pos ~D: found ~D at pos ~D [count ~D].~%"
+                  stored i value pos count)
+          (return nil))))))
+
+(deftest :btree.1
+    (dotimes (i 1000 t)
+      (test-btree-vector i))
+  t)
+
+(defun time-btree (&optional (fn #'sorted-vector-find) (return-on-error nil))
+  (time
+   (let ((total-count 0))
+     (declare (fixnum total-count))
+     (dotimes (i (length *btree-vector*) t)
+       (let ((stored (aref *btree-vector* i)))
+         (multiple-value-bind (value pos count)
+             (funcall fn stored *btree-vector*)
+           (incf total-count count)
+           (when (or (/= i pos) (/= stored value))
+             (format t "~&Error: btree value ~D at pos ~D: found ~D at pos ~D [count ~D].~%"
+                     stored i value pos count)
+             (when return-on-error
+               (return-from time-btree nil))))))
+     (float (/ total-count (length *btree-vector*))))))
+
+;;; MOP Testing
 
 ;; Disable attrib class until understand changes in sbcl/cmucl
 ;; using COMPUTE-SLOT-ACCESSOR-INFO and defining method