Version 1.102 (other changes not in last commit)

[kmrcl.git] / tests.lisp

diff --git a/tests.lisp b/tests.lisp
index 4cbc915f430f61d6e8f4079c79672b1e769b748e..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
 ;;;;
 ;;;; *************************************************************************
 
@@ -202,6 +200,15 @@
 (deftest :sse.4 (string-strip-ending "abc" '("ab")) "abc")
 (deftest :sse.5 (string-strip-ending "abcd" '("a" "cd")) "ab")
 
+(deftest :rcs.1 (remove-char-string #\space "") "")
+(deftest :rcs.2 (remove-char-string #\space "a") "a")
+(deftest :rcs.3 (remove-char-string #\space "ab") "ab")
+(deftest :rcs.4 (remove-char-string #\space "a b") "ab")
+(deftest :rcs.5 (remove-char-string #\space " a b") "ab")
+(deftest :rcs.6 (remove-char-string #\space "a b ") "ab")
+(deftest :rcs.7 (remove-char-string #\space "a  b   c  ") "abc")
+(deftest :rcs.8 (remove-char-string #\space "a  b   c  d") "abcd")
+
 
 (defun test-color-conversion ()
   (dotimes (ih 11)
@@ -429,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