Test output for datatypes [ok]

Testing time: 7s

'/usr/home/chicken/salmonella/build/salmonella-run-publish/chicken/bin/csi' -script run.scm < /dev/null 2>&1

Testing DATATYPES ...
----------------------------
"Immutable lists as concrete types"
... passed in (concrete-types?)
(define-concrete-type LIST List? (List-null) (List-cons (first) (rest List?)))
... passed in (concrete-types?)
(define (Null? obj) (concrete-case (obj List?) ((List-null) #t) (else #f)))
... passed in (concrete-types?)
(define (List-first obj)
  (concrete-case
    (obj List?)
    ((List-null) (error 'List-first))
    ((List-cons first rest) first)))
... passed in (concrete-types?)
(define (List-rest obj)
  (concrete-case
    (obj List?)
    ((List-null) (error 'List-rest))
    ((List-cons first rest) rest)))
... passed in (concrete-types?)
(define Lst (List-null))
... passed in (concrete-types?)
(Null? Lst)
... passed in (concrete-types?)
(set! Lst (List-cons 1 Lst))
... passed in (concrete-types?)
(not (Null? Lst))
... passed in (concrete-types?)
(Null? (List-rest Lst))
... passed in (concrete-types?)
(= 1 (List-first Lst))
... passed in (concrete-types?)
"Integers as chains"
... passed in (concrete-types?)
(define-concrete-type
  CHAIN
  chain?
  (Chain-link (item integer? (lambda (x) (>= x 0))) (next procedure?)))
... passed in (concrete-types?)
(define (integers n) (Chain-link n integers))
... passed in (concrete-types?)
(not (chain? integers))
... passed in (concrete-types?)
(chain? (integers 0))
... passed in (concrete-types?)
(chain? (integers 10))
... passed in (concrete-types?)
(define (chain-item n xpr)
  (concrete-case
    (xpr chain?)
    ((Chain-link i fn) (if (= n 1) i (chain-item (- n 1) (fn (+ i 1)))))))
... passed in (concrete-types?)
(= 0 (chain-item 1 (integers 0)))
... passed in (concrete-types?)
(= 25 (chain-item 26 (integers 0)))
... passed in (concrete-types?)
"Points as abstract types"
... passed in (abstract-types?)
(define-abstract-type
  POINT
  point?
  (Point (x number?) (y number?))
  (with ((make-point x y) (Point x y))
        ((point-x pt) (concrete-case (pt point?) ((Point x y) x)))
        ((point-y pt) (concrete-case (pt point?) ((Point x y) y))))
  (printer
    (lambda (pt out)
      (display "#,(POINT " out)
      (display (point-x pt) out)
      (display " " out)
      (display (point-y pt) out)
      (display ")\n" out)))
  (reader Point))
... passed in (abstract-types?)
(define pt (make-point 1 2))
... passed in (abstract-types?)
#,(POINT 1 2)

(print pt)
... passed in (abstract-types?)
(= (point-x pt) 1)
... passed in (abstract-types?)
(point? pt)
... passed in (abstract-types?)
(not (point? Lst))
... passed in (abstract-types?)
(define-object-type
  COUPLE
  couple?
  make-couple
  ((parent object?) (x (cell-of? number?)) (y (cell-of? number?)))
  (override)
  ((First) (cell-ref x))
  ((Second) (cell-ref y))
  ((First-set! (arg number?)) (set! (cell-ref x) arg))
  ((Second-set! (arg number?)) (set! (cell-ref y) arg)))
... passed in (object-types?)
(define-object-type
  TRIPLE
  triple?
  make-triple
  ((parent couple?) (z (cell-of? number?)))
  (override
    ((First) (* 2 (parent (First))))
    ((First-set! arg) (parent (First-set! (* 2 arg)))))
  ((Third) (cell-ref z))
  ((Third-set! (arg number?)) (set! (cell-ref z) arg)))
... passed in (object-types?)
(define-object-type
  FOO
  foo?
  make-foo
  ((parent object?) (x (cell-of? integer?)))
  (override)
  ((First) (cell-ref x))
  ((First-set! (arg integer?)) (set! (cell-ref x) arg)))
... passed in (object-types?)
(define obj (make-base-object))
... passed in (object-types?)
(object? obj)
... passed in (object-types?)
(obj (Types))
... passed in (object-types?)
(obj (Invariant))
... passed in (object-types?)
(obj (Info))
... passed in (object-types?)
(define foo (make-foo obj (cell 101)))
... passed in (object-types?)
(= (foo (First)) 101)
... passed in (object-types?)
(foo (First-set! 202))
... passed in (object-types?)
(= (foo (First)) 202)
... passed in (object-types?)
(define cpl (make-couple obj (cell 1) (cell 2)))
... passed in (object-types?)
(couple? cpl)
... passed in (object-types?)
(object? cpl)
... passed in (object-types?)
(not (couple? First))
... passed in (object-types?)
(cpl (Types))
... passed in (object-types?)
(cpl (Info))
... passed in (object-types?)
(cpl (Invariant))
... passed in (object-types?)
(cpl (Ancestors))
... passed in (object-types?)
(= (cpl (First)) 1)
... passed in (object-types?)
(= (cpl (Second)) 2)
... passed in (object-types?)
(cpl (First-set! 10))
... passed in (object-types?)
(cpl (Second-set! 20))
... passed in (object-types?)
(= (cpl (First)) 10)
... passed in (object-types?)
(= (cpl (Second)) 20)
... passed in (object-types?)
(define trp (make-triple cpl (cell 3)))
... passed in (object-types?)
(trp (Ancestors))
... passed in (object-types?)
(trp (Info))
... passed in (object-types?)
(= (trp (Third)) 3)
... passed in (object-types?)
(trp (Third-set! 30))
... passed in (object-types?)
(= (trp (Third)) 30)
... passed in (object-types?)
(= (trp (First)) 20)
... passed in (object-types?)
(= (trp (Second)) 20)
... passed in (object-types?)
(trp (Second-set! 2))
... passed in (object-types?)
(= (trp (Second)) 2)
... passed in (object-types?)
(trp (First-set! 25))
... passed in (object-types?)
(= (trp (First)) 100)
... passed in (object-types?)
(triple? trp)
... passed in (object-types?)
(not (triple? cpl))
... passed in (object-types?)
(couple? trp)
... passed in (object-types?)
(object? trp)
... passed in (object-types?)

Results of DATATYPES
----------------------------
All tests passed