[elephant-cvs] CVS update: elephant/tests/testserializer.lisp
blee at common-lisp.net
blee at common-lisp.net
Sat Sep 4 08:25:13 UTC 2004
Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp.net:/tmp/cvs-serv12983/tests
Modified Files:
testserializer.lisp
Log Message:
made into RT tests, added a bunch
Date: Sat Sep 4 10:25:08 2004
Author: blee
Index: elephant/tests/testserializer.lisp
diff -u elephant/tests/testserializer.lisp:1.2 elephant/tests/testserializer.lisp:1.3
--- elephant/tests/testserializer.lisp:1.2 Thu Sep 2 09:32:16 2004
+++ elephant/tests/testserializer.lisp Sat Sep 4 10:25:07 2004
@@ -1,27 +1,367 @@
-(in-package "ELE")
+(in-package :ele-tests)
+(import 'ele::*out-buf*)
+(import 'ele::serialize)
+(import 'ele::deserialize)
+(import 'ele::buffer-stream-buffer)
-(defun test (var)
+(defun in-out-value (var)
(serialize var *out-buf*)
(deserialize (buffer-stream-buffer *out-buf*)))
-(= 10000000000 (test 10000000000))
+(defun in-out-eq (var)
+ (serialize var *out-buf*)
+ (eq var (deserialize (buffer-stream-buffer *out-buf*))))
+
+(defun in-out-equal (var)
+ (serialize var *out-buf*)
+ (equal var (deserialize (buffer-stream-buffer *out-buf*))))
+
+(defun in-out-equalp (var)
+ (serialize var *out-buf*)
+ (equalp var (deserialize (buffer-stream-buffer *out-buf*))))
+
+(deftest fixnums
+ (values
+ (in-out-equal 0)
+ (in-out-equal -1)
+ (in-out-equal 1)
+ (in-out-equal most-positive-fixnum)
+ (in-out-equal most-negative-fixnum))
+ t t t t t)
+
+(deftest fixnum-type-1
+ (values
+ (typep (in-out-value 0) 'fixnum)
+ (typep (in-out-value 1) 'fixnum)
+ (typep (in-out-value -1) 'fixnum)
+ (typep (in-out-value most-positive-fixnum) 'fixnum)
+ (typep (in-out-value most-negative-fixnum) 'fixnum))
+ t t t t t)
+
+(deftest bignums
+ (values
+ (in-out-equal 10000000000)
+ (in-out-equal -10000000000)
+ (loop for i from 0 to 2000
+ always (in-out-equal (expt 2 i)))
+ (loop for i from 0 to 2000
+ always (in-out-equal (- (expt 2 i))))
+ (loop for i from 0 to 2000
+ always (in-out-equal (- (expt 2 i) 1)))
+ (loop for i from 0 to 2000
+ always (in-out-equal (- 1 (expt 2 i))))
+ (loop for i from 0 to 2000
+ always (in-out-equal (expt 3 i)))
+ (loop for i from 0 to 2000
+ always (in-out-equal (- (expt 3 i)))))
+ t t t t t t t t)
+
+(deftest floats
+ (values
+ (in-out-equal 0.0)
+ (in-out-equal -0.0)
+ (in-out-equal 0.0d0)
+ (in-out-equal -0.0d0)
+ (in-out-equal -0.0d0)
+ (in-out-equal double-float-epsilon)
+ (in-out-equal long-float-epsilon)
+ (in-out-equal short-float-epsilon)
+ (in-out-equal single-float-epsilon)
+ (in-out-equal double-float-negative-epsilon)
+ (in-out-equal long-float-negative-epsilon)
+ (in-out-equal short-float-negative-epsilon)
+ (in-out-equal single-float-negative-epsilon)
+ (in-out-equal least-negative-double-float)
+ (in-out-equal least-negative-long-float)
+ (in-out-equal least-negative-short-float)
+ (in-out-equal least-negative-single-float)
+ (in-out-equal least-positive-double-float)
+ (in-out-equal least-positive-long-float)
+ (in-out-equal least-positive-short-float)
+ (in-out-equal least-positive-single-float)
+ (in-out-equal most-negative-double-float)
+ (in-out-equal most-negative-long-float)
+ (in-out-equal most-negative-short-float)
+ (in-out-equal most-negative-single-float)
+ (in-out-equal most-positive-double-float)
+ (in-out-equal most-positive-long-float)
+ (in-out-equal most-positive-short-float)
+ (in-out-equal most-positive-single-float))
+ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t)
+
+(deftest rationals
+ (values
+ (in-out-equal 1/2)
+ (in-out-equal -1/2)
+ (in-out-equal (/ 1 most-positive-fixnum))
+ (in-out-equal (/ 1 most-negative-fixnum))
+ (in-out-equal (/ most-positive-fixnum most-negative-fixnum))
+ (in-out-equal (/ (expt 2 200) (expt 3 300)))
+ (in-out-equal (/ (expt 2 200) (- (expt 3 300)))))
+ t t t t t t t)
+
+(deftest strings
+ (values
+ (in-out-equal "")
+ (in-out-equal "this is a test")
+ (in-out-equal (make-string 400 :initial-element (code-char 254))))
+ t t t)
+
+(defun in-out-uninterned-equal (var)
+ (serialize var *out-buf*)
+ (let ((new (deserialize (buffer-stream-buffer *out-buf*))))
+ (and (equal (symbol-name new) (symbol-name var))
+ (equal (symbol-package new) (symbol-package var)))))
+
+(deftest symbols
+ (values
+ (in-out-equal nil)
+ (in-out-equal T)
+ (in-out-equal 'foobarbazquux)
+ (in-out-equal 'ele::next-oid)
+ (in-out-equal :a-keyword-symbol)
+ (in-out-uninterned-equal '#:foozle)
+ (in-out-uninterned-equal (make-symbol "a wha wah ba ba"))
+ (in-out-uninterned-equal (make-symbol "")))
+ t t t t t t t t)
+
+(deftest chars
+ (loop for i from 0 below char-code-limit
+ unless (in-out-equal (code-char i))
+ do (return i)
+ finally (return T))
+ t)
+
+(deftest pathnames
+ ;;; Given how implementation-specific make-pathname is,
+ ;;; i don't know how to put more portable tests here!
+ (values
+ (in-out-equal #p"/usr/local/share/common-lisp/elephant"))
+ t)
+
+(deftest conses
+ (values
+ (in-out-equal (cons t 100000))
+ (in-out-equal (list 1 'a "this is a test" 'c 10000 nil 1000 nil))
+ (in-out-equal (cons (cons (cons t nil) (cons nil t)) (cons 1 (cons t nil))))
+ )
+ t t t)
+
+(deftest hash-tables-1
+ (let* ((ht (make-hash-table :test 'equalp :size 333 :rehash-size 1.2
+ :rehash-threshold 0.8))
+ (size (hash-table-size ht))
+ (rehash-size (hash-table-rehash-size ht))
+ (rehash-threshold (hash-table-rehash-threshold ht))
+ (out (in-out-value ht)))
+ (values
+ (eq (hash-table-test out) 'equalp)
+ (= (hash-table-size ht) size)
+ (= (hash-table-rehash-size ht) rehash-size)
+ (= (hash-table-rehash-threshold ht) rehash-threshold)
+ (eq (hash-table-test (in-out-value (make-hash-table :test 'eq))) 'eq)
+ (eq (hash-table-test (in-out-value (make-hash-table :test 'eql))) 'eql)
+ (eq (hash-table-test
+ (in-out-value (make-hash-table :test 'equal))) 'equal)
+ (eq (hash-table-test
+ (in-out-value (make-hash-table :test 'equalp))) 'equalp)))
+ t t t t t t t t)
+
+(deftest hash-tables-2
+ (let ((ht (make-hash-table :test 'equalp)))
+ (setf (gethash (cons nil nil) ht) "one")
+ (setf (gethash 2 ht) 2.0d0)
+ (setf (gethash 'symbolsymbol ht) "three")
+ (let ((out (in-out-value ht)))
+ (values
+ (string= (gethash (cons nil nil) ht) "one")
+ (= (gethash 2 ht) 2.0d0)
+ (string= (gethash 'symbolsymbol ht) "three"))))
+ t t t)
+
+(defun type= (t1 t2)
+ (and (subtypep t1 t2) (subtypep t2 t1)))
+
+(deftest arrays-1
+ (values
+ (array-has-fill-pointer-p
+ (in-out-value (make-array 200 :fill-pointer t)))
+ (not (array-has-fill-pointer-p
+ (in-out-value (make-array 200 :fill-pointer nil))))
+ (type= (upgraded-array-element-type '(unsigned-byte 20))
+ (array-element-type
+ (in-out-value (make-array '(3 4 5)
+ :element-type
+ '(unsigned-byte 20)))))
+ (type= (upgraded-array-element-type 'fixnum)
+ (array-element-type
+ (in-out-value (make-array '(3 4 5)
+ :element-type
+ 'fixnum))))
+ )
+ t t t t)
+
+(deftest arrays-2
+ (let ((arr (make-array '(3 4 5)))
+ (vec (make-array 100 :adjustable t :fill-pointer t))
+ (svec (make-array 100 :adjustable nil :fill-pointer nil)))
+ (setf (aref arr 0 0 0) 'symb)
+ (setf (aref arr 1 2 3) 123132)
+ (setf (aref arr 2 3 4) "this is a longish string")
+ (vector-push-extend 123456789101112 vec)
+ (vector-push-extend "mr t" vec)
+ (vector-push-extend 'symbolic vec)
+ (loop for i from 0 to 99
+ do
+ (setf (svref svec i) (expt 2 i)))
+ (values
+ (in-out-equalp arr)
+ (in-out-equalp vec)
+ (in-out-equalp svec)
+ (typep (in-out-value svec) 'simple-vector)))
+ t t t t)
+
+
+;; depends on ele::slots-and-values
+(defun deep-equalp (thing another)
+ (let ((seen (make-hash-table :test 'eq)))
+ (labels
+ ((%deep-equalp (s1 s2)
+ (when (type= (type-of s1) (type-of s2))
+ (if (gethash s1 seen) t
+ (progn
+ (setf (gethash s1 seen) t)
+ (typecase s1
+ (cons
+ (and (%deep-equalp (car s1) (car s2))
+ (%deep-equalp (cdr s1) (cdr s2))))
+ (array
+ (loop for i from 0 below (array-total-size s1)
+ always (%deep-equalp
+ (row-major-aref s1 i)
+ (row-major-aref s2 i))))
+ (hash-table
+ (when (= (hash-table-count s1)
+ (hash-table-count s2))
+ (loop for key being the hash-key of s1
+ using (hash-value value)
+ always (%deep-equalp value
+ (gethash key s2)))))
+ (standard-object
+ (%deep-equalp (ele::slots-and-values s1)
+ (ele::slots-and-values s2)))
+ (t (equalp s1 s2))))))))
+ (%deep-equalp thing another))))
+
+(defclass foo ()
+ ((slot1 :initarg :slot1)
+ (slot2 :initarg :slot2)))
+
+(defclass bar ()
+ ((slot1 :initarg :slot1)
+ (slot2 :initarg :slot2)))
+
+(deftest test-deep-equalp
+ (let ((c1 (cons nil nil))
+ (c2 (cons nil nil))
+ (l1 (make-list 100))
+ (h (make-hash-table :test 'equal))
+ (g (make-array '(2 3 4)))
+ (f (make-instance 'foo))
+ (b (make-instance 'bar)))
+ (setf (car c1) c1)
+ (setf (cdr c1) c1)
+ (setf (car c2) c1)
+ (setf (cdr c2) c2)
+ (setf (cdr (last l1)) l1)
+ (setf (gethash "quux" h) l1)
+ (setf (gethash "bar" h) c2)
+ (setf (aref g 1 1 1) g)
+ (setf (aref g 0 0 1) h)
+ (setf (gethash "foo" h) g)
+ (setf (slot-value f 'slot1) b)
+ (setf (slot-value f 'slot2) f)
+ (setf (slot-value b 'slot1) h)
+ (setf (slot-value b 'slot2) f)
+ (values
+ (deep-equalp c1 c1)
+ (deep-equalp c2 c2)
+ (deep-equalp l1 l1)
+ (deep-equalp h h)
+ (deep-equalp g g)
+ (deep-equalp f f)
+ (deep-equalp b b)))
+ t t t t t t t)
+
+(defun in-out-deep-equalp (var)
+ (serialize var *out-buf*)
+ (deep-equalp var (deserialize (buffer-stream-buffer *out-buf*))))
+
+(deftest objects
+ (values
+ (in-out-deep-equalp (make-instance 'foo))
+ (in-out-deep-equalp (make-instance 'bar :slot1
+ (make-instance 'foo
+ :slot2 "foo bar"))))
+ t t)
+
+(deftest circular
+ (let ((c1 (cons nil nil))
+ (c2 (cons nil nil))
+ (l1 (make-list 100))
+ (h (make-hash-table :test 'equal))
+ (g (make-array '(2 3 4)))
+ (f (make-instance 'foo))
+ (b (make-instance 'bar)))
+ (setf (car c1) c1)
+ (setf (cdr c1) c1)
+ (setf (car c2) c1)
+ (setf (cdr c2) c2)
+ (setf (cdr (last l1)) l1)
+ (setf (gethash "quux" h) l1)
+ (setf (gethash "bar" h) c2)
+ (setf (aref g 1 1 1) g)
+ (setf (aref g 0 0 1) h)
+ (setf (gethash "foo" h) g)
+ (setf (slot-value f 'slot1) b)
+ (setf (slot-value f 'slot2) f)
+ (setf (slot-value b 'slot1) h)
+ (setf (slot-value b 'slot2) f)
+ (values
+ (in-out-deep-equalp c1)
+ (in-out-deep-equalp c2)
+ (in-out-deep-equalp l1)
+ (in-out-deep-equalp h)
+ (in-out-deep-equalp g)
+ (in-out-deep-equalp f)
+ (in-out-deep-equalp b)))
+ t t t t t t t)
-(equalp (cons 10000000000 10000000000)
- (test (cons 10000000000 10000000000)))
+(defclass pfoo ()
+ ((slot1 :initarg :slot1 :accessor slot1))
+ (:metaclass persistent-metaclass))
-(setq f (cons nil nil))
-(prog1 t (setf (car f) f))
-(prog1 t (setq g (test f)))
-(eq g (car g))
-(eq nil (cdr g))
-
-(setq h (make-hash-table :test 'eql))
-(prog1 t (setf (gethash 10000000000 h) f))
-(setq h2 (test h))
-(= 1 (hash-table-count h2))
-(prog1 t (setq g (gethash 10000000000 h2)))
-(eq g (car g))
-(eq nil (cdr g))
+(defclass pbar (pfoo)
+ ((slot2 :initarg :slot2 :accessor slot2))
+ (:metaclass persistent-metaclass))
-;(defclass foo ()
-; ((slot1 :type
\ No newline at end of file
+(deftest persistent
+ (let ((f1 (make-instance 'pfoo))
+ (f2 (make-instance 'pfoo :slot1 "this is a string"))
+ (b1 (make-instance 'pbar :slot2 "another string"))
+ (b2 (make-instance 'pbar))
+ (h (make-instance 'btree)))
+ (values
+ (in-out-eq f1)
+ (in-out-eq f2)
+ (in-out-eq b1)
+ (in-out-eq b2)
+ (in-out-eq h)
+ (signals-condition
+ (slot1 f1))
+ (progn (setf (slot1 f1) f1)
+ (eq f1 (slot1 f1)))
+ (progn (setf (get-value f2 h) f2)
+ (eq (get-value f2 h) f2))))
+ t t t t t t t t)
+
\ No newline at end of file
More information about the Elephant-cvs
mailing list