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