Test output for tinyclos [ok]

• Report summary
• Installation report
• Test report
• Dependencies graphs
• Reverse dependencies graphs

Testing time: 11s

/home/mario/local/chicken-4.8.0.3/bin/csi -script run.scm < /dev/null

;;; BEGIN "tinyclos" TESTS

;; 1. Primitive null
(class-name (class-of (quote ())))
;; ==> "null"
;; Passed.

;; 2. Primitive exact
(class-name (class-of 11))
;; ==> "exact"
;; Passed.

;; 3. Primitive boolean
(class-name (class-of #t))
;; ==> "boolean"
;; Passed.

;; 4. Primitive char
(class-name (class-of #\+))
;; ==> "char"
;; Passed.

;; 5. Primitive eof
(let ((c (with-input-from-string "" (lambda () (read-char))))) (class-name (class-of c)))
;; ==> "end-of-file"
;; Passed.

;; 6. Primitive void
(class-name (class-of (if #f (quote ()))))
;; ==> "void"
;; Passed.

;; 7. Primitive inexact
(class-name (class-of 11.0))
;; ==> "inexact"
;; Passed.

;; 8. Primitive symbol
(class-name (class-of (quote abc)))
;; ==> "symbol"
;; Passed.

;; 9. Primitive vector
(class-name (class-of (quote #(1 2 3))))
;; ==> "vector"
;; Passed.

;; 10. Primitive pair
(class-name (class-of (quote (a . b))))
;; ==> "pair"
;; Passed.

;; 11. Primitive string
(class-name (class-of "only this"))
;; ==> "string"
;; Passed.

;; 12. Primitive procedure
(class-name (class-of (lambda () #t)))
;; ==> "procedure"
;; Passed.

;; 13. Primitive input port
(class-name (class-of (current-input-port)))
;; ==> "input-port"
;; Passed.

;; 14. Primitive output port
(class-name (class-of (current-output-port)))
;; ==> "output-port"
;; Passed.

;; 15. Primitive blob
(class-name (class-of (make-blob 10)))
;; ==> "blob"
;; Passed.

;; 16. Primitive locative
(class-name (class-of (make-locative "xyz")))
;; ==> "locative"
;; Passed.

;; 17. Primitive environment
(class-name (class-of (scheme-report-environment 5)))
;; ==> "environment"
;; Passed.

;; 18. Primitive array
(class-name (class-of (make-array (shape 0 10 0 5))))
;; ==> "array"
;; Passed.

;; 19. Primitive hash-table
(class-name (class-of (make-hash-table)))
;; ==> "hash-table"
;; Passed.

;; 20. Primitive queue
(class-name (class-of (make-queue)))
;; ==> "queue"
;; Passed.

;; 21. Primitive condition
(let ((cn (condition-case (/ 1 0) (v () v)))) (class-name (class-of cn)))
;; ==> "condition"
;; Passed.

;; 22. Primitive condition-variable
(class-name (class-of (make-condition-variable)))
;; ==> "condition-variable"
;; Passed.

;; 23. Primitive char-set
(class-name (class-of (make-char-set "a")))
;; ==> "char-set"
;; Passed.

;; 24. Primitive time
(class-name (class-of (current-time)))
;; ==> "time"
;; Passed.

;; 25. Primitive lock
(let* ((lock (file-lock (current-output-port))) (name (class-name (class-of lock)))) (file-unlock lock) name)
;; ==> "lock"
;; Passed.

;; 26. Primitive mmap
(let* ((fileno (file-open MMAP_FILENAME open/rdonly)) (memory-map (map-file-to-memory #f 20 prot/read map/fixed fileno)) (name (class-name (class-of memory-map)))) (file-close fileno) name)
;; ==> "mmap"
;; Passed.

;; 27. Primitive promise
(class-name (class-of (delay (+ 1 2))))
;; ==> "promise"
;; Passed.

;; 28. Primitive u8vector
(class-name (class-of (make-u8vector 10)))
;; ==> "u8vector"
;; Passed.

;; 29. Primitive s8vector
(class-name (class-of (make-s8vector 10)))
;; ==> "s8vector"
;; Passed.

;; 30. Primitive u16vector
(class-name (class-of (make-u16vector 10)))
;; ==> "u16vector"
;; Passed.

;; 31. Primitive s16vector
(class-name (class-of (make-s16vector 10)))
;; ==> "s16vector"
;; Passed.

;; 32. Primitive u32vector
(class-name (class-of (make-u32vector 10)))
;; ==> "u32vector"
;; Passed.

;; 33. Primitive f32vector
(class-name (class-of (make-f32vector 10)))
;; ==> "f32vector"
;; Passed.

;; 34. Primitive f64vector
(class-name (class-of (make-f64vector 10)))
;; ==> "f64vector"
;; Passed.

;; 35. Primitive tcp-listener
(let* ((listener (tcp-listen 12345)) (name (class-name (class-of listener)))) (tcp-close listener) name)
;; ==> "tcp-listener"
;; Passed.

;; 36. Primitive mutex
(class-name (class-of (make-mutex)))
;; ==> "mutex"
;; Passed.

;; 37. Primitive continuation
(class-name (class-of (continuation-capture (lambda (x) x))))
;; ==> "continuation"
;; Passed.

;; 38. Primitive read-table
(class-name (class-of (current-read-table)))
;; ==> "read-table"
;; Passed.

;; 39. Primitive regexp
(class-name (class-of (regexp "a")))
;; ==> "regexp"
;; Passed.

;; 40. Simple class creation
(let* ((<c1> (make-class (list <object>) (quote ())))) (class-direct-supers (class-of (make <c1>))))
;; ==> (#<class object>)
;; Passed.

;; 41. Class slots
(let* ((<c2> (make-class (list <object>) (quote (a b)))) (object (make <c2>))) (slot-set! object (quote a) 12345) (slot-set! object (quote b) (/ 12345 5)) (/ (slot-ref object (quote a)) (slot-ref object (quote b))))
;; ==> 5
;; Passed.

;; 42. Instance-of?
(let* ((<pos> (define-class* () (x y))) (<circle> (define-class* (<pos>) (radius))) (p (make <pos>)) (c (make <circle>)) (g (make-generic)) (profile (lambda (x) (list (instance-of? x <pos>) (instance-of? x <circle>) (instance-of? x <object>) (instance-of? x <class>) (instance-of? x <primitive-class>) (instance-of? x <generic>) (instance-of? x <primitive>))))) (list (profile p) (profile c) (profile g) (profile 12)))
;; ==> ((#t #f #t #f #f #f #f) (#t #t #t #f #f #f #f) (#f #f #t #f #f #t #f) (#f #f #f #f #f #f #t))
;; Passed.

;; 43. subclass?
(let* ((<pos> (define-class* () (x y))) (<circle> (define-class* (<pos>) (radius))) (profile (lambda (x) (list (subclass? x <pos>) (subclass? x <circle>) (subclass? x <object>) (subclass? x <class>) (subclass? x <primitive-class>) (subclass? x <generic>) (subclass? x <primitive>))))) (list (profile <pos>) (profile <circle>) (profile <primitive-class>) (profile <primitive>)))
;; ==> ((#t #f #t #f #f #f #f) (#t #t #t #f #f #f #f) (#f #f #t #t #t #f #f) (#f #f #f #f #f #f #t))
;; Passed.

;; 44. Generic with no methods
(let ((gen (make-generic))) (condition-case (gen) (v () ((condition-property-accessor (quote exn) (quote message)) v))))
;; ==> "generic: has no methods"
;; Passed.

;; 45. Generic method called with inappropriate argument
(let* ((gen (make-generic)) (ignore (define-method (gen (x <inexact>)) (* x 3)))) (condition-case (gen 1) (v () ((condition-property-accessor (quote exn) (quote message)) v))))
;; ==> "call-next-method: no methods left"
;; Passed.

;; 46. Generic method called with appropriate argument
(let* ((gen (make-generic)) (ignore (define-method (gen (x <inexact>)) (* x 3)))) (condition-case (gen 1.0) (v () ((condition-property-accessor (quote exn) (quote message)) v))))
;; ==> 3.0
;; Passed.

;; 47. Distance: generic method
(let* ((<pos> (define-class* () (x y))) (ignore1 (define-method (initialize (pos <pos>) initargs) (call-next-method) (initialize-slots pos initargs))) (p1 (make <pos> (quote x) 10 (quote y) 18)) (p2 (make <pos> (quote x) 1 (quote y) 30)) (distance (make-generic)) (ignore2 (define-method (distance (pos1 <pos>) (pos2 <pos>)) (let ((xdiff (- (slot-ref pos1 (quote x)) (slot-ref pos2 (quote x)))) (ydiff (- (slot-ref pos1 (quote y)) (slot-ref pos2 (quote y))))) (sqrt (+ (* xdiff xdiff) (* ydiff ydiff))))))) (distance p1 p2))
;; ==> 15.0
;; Passed.

;; 48. Move and resize: generic methods and polymorphism
(let* ((<pos> (define-class* () (x y))) (<circle> (define-class* (<pos>) (radius))) (ignore1 (define-method (initialize (pos <pos>) initargs) (call-next-method) (initialize-slots pos initargs))) (p1 (make <pos> (quote x) 10 (quote y) 18)) (c1 (make <circle> (quote x) 1 (quote y) 30)) (position (make-generic)) (size (make-generic)) (move (make-generic)) (resize (make-generic)) (ignore2 (define-method (position (pos <pos>)) (cons (slot-ref pos (quote x)) (slot-ref pos (quote y))))) (ignore3 (define-method (size (circle <circle>)) (slot-ref circle (quote radius)))) (ignore4 (define-method (resize (circle <circle>) r) (slot-set! circle (quote radius) r))) (ignore5 (define-method (move (pos1 <pos>) (pos2 <pos>)) (slot-set! pos1 (quote x) (slot-ref pos2 (quote x))) (slot-set! pos1 (quote y) (slot-ref pos2 (quote y))))) (c (make <circle> (quote x) 0 (quote y) 0 (quote radius) 10)) (p (make <pos> (quote x) 10 (quote y) 11))) (list (with-output-to-string (lambda () (detail-object c))) (begin (move c p) (with-output-to-string (lambda () (detail-object c)))) (begin (resize c 8) (with-output-to-string (lambda () (detail-object c))))))
;; ==> ("#,(instance \"(anonymous)\" (radius 10 x 0 y 0))" "#,(instance \"(anonymous)\" (radius 10 x 10 y 11))" "#,(instance \"(anonymous)\" (radius 8 x 10 y 11))")
;; Passed.

;; 49. make/copy test
(let* ((<person> (define-class* () (name age))) (<customer> (define-class* (<person>) (last-contact-date purchases customer-number))) (ignore (define-method (initialize (p <person>) initargs) (initialize-slots p initargs))) (customer-number (lambda (c) (slot-ref c (quote customer-number)))) (name (lambda (c) (slot-ref c (quote name)))) (purchases (lambda (c) (slot-ref c (quote purchases)))) (p1 (make <customer> (quote name) "John" (quote purchases) 12.8 (quote customer-number) 11)) (p2 (make/copy p1 (quote name) "Peter" (quote customer-number) 12))) (list (cons (customer-number p1) (customer-number p2)) (cons (name p1) (name p2)) (cons (purchases p1) (purchases p2))))
;; ==> ((11 . 12) ("John" . "Peter") (12.8 . 12.8))
;; Passed.

;; 50. dotted argument in method (1)
(let* ((<pos> (define-class* () (x y))) (gen (make-generic)) (p (make <pos>))) (define-method (gen (p <pos>) . args) args) (gen p "a"))
;; ==> ("a")
;; Passed.

;; 51. dotted argument in method (2)
(let* ((<pos> (define-class* () (x y))) (gen (make-generic)) (ignore (define-method (gen (p <pos>) . args) args)) (p (make <pos>))) (gen p))
;; ==> ()
;; Passed.

;; 52. dotted argument in method (3)
(let* ((<pos> (define-class* () (x y))) (gen (make-generic)) (p (make <pos>))) (define-method (gen (p <pos>) a . args) args) (gen p (quote a) (quote b)))
;; ==> (b)
;; Passed.

;; 53. dotted argument in method competing with non-dotted method (1)
(let* ((<pos> (define-class* () (x y))) (gen (make-generic)) (p (make <pos>))) (define-method (gen (p <pos>) a) "non-dotted") (define-method (gen (p <pos>) a . args) "dotted") (gen p (quote a)))
;; ==> "dotted"
;; Passed.

;; 54. dotted argument in method competing with non-dotted method (2)
(let* ((<pos> (define-class* () (x y))) (gen (make-generic)) (p (make <pos>))) (define-method (gen (p <pos>) a . args) "dotted") (define-method (gen (p <pos>) a) "non-dotted") (gen p (quote a)))
;; ==> "non-dotted"
;; Passed.

;; 55. Structure class-of test
(begin (define-record point x y) (define-record circle x y r) (delete-structure-class-of (quote non-existent)) (let ((<point> (make <primitive-class> (quote direct-supers) (list <primitive>) (quote direct-slots) (quote ()) (quote name) (quote point))) (<circle> (make <primitive-class> (quote direct-supers) (list <primitive>) (quote direct-slots) (quote ()) (quote name) (quote circle))) (<duplicate-of-point> (make <primitive-class> (quote direct-supers) (list <primitive>) (quote direct-slots) (quote ()) (quote name) (quote dupe)))) (add-structure-class-of (quote point) <point>) (add-structure-class-of (quote circle) <circle>) (add-structure-class-of (quote point) <duplicate-of-point>) (let* ((cnm (lambda (x) (class-name (class-of x)))) (name1 (cnm (make-point 1 1))) (name2 (cnm (make-circle 1 2 2)))) (delete-structure-class-of (quote point)) (delete-structure-class-of (quote random-symbol)) (let ((name3 (cnm (make-point 10 10))) (name4 (cnm (make-circle 10 10 20)))) (delete-structure-class-of (quote circle)) (let ((name5 (cnm (make-point 0 0))) (name6 (cnm (make-circle 1 5 4)))) (delete-structure-class-of (quote does-not-exist)) (list name1 name2 name3 name4 name5 name6))))))
;; ==> ("dupe" "circle" "structure" "circle" "structure" "structure")
;; Passed.

;; 56. Mutable class name - this is not good
(let ((<testprim> (make <primitive-class> (quote direct-supers) (list <primitive>) (quote direct-slots) (quote ()) (quote name) "test T"))) (let ((before (string-copy (class-name <testprim>)))) (string-set! (class-name <testprim>) 5 #\_) (list before (class-name <testprim>))))
;; ==> ("test T" "test _")
;; Passed.

;;; END "tinyclos" TESTS: PASSED
;;;     (Total: 56  Passed: 56  Failed: 0)