;;;; t.scm - tests for typed-records.scm


(import typed-records test)

(define-record point
  x
  (y : number))

(define-record-type point3
  (make-point3 y x)
  point3?
  (x get-x set-x : number)
  (y get-y : number)
  (foo get-foo)
  (bar get-bar set-bar)
  (baz get-baz : float)
  (goo get-goo set-foo : pointer))

(defstruct person
  name
  (age : fixnum)
  ((species 'human) : symbol)
  (planet 'earth))

(define-syntax assert-type
  (syntax-rules ()
    ((_ t x)
     (cond-expand
       (compiling
	(test 'ok
          (compiler-typecase x
            (t 'ok)
            (* 'wrong)
            (else 'ok))))
       (else #f)))))

(let ((pt (make-point 1 2))
      (p3 (make-point3 1 2)))

  (assert-type number (point-y pt))
  (assert-type float (get-baz p3))

  (when (point? pt)
    (assert-type (struct point) pt))

  (assert-type (struct person) (make-person))

  (let ((p (make-person age: 33)))
    #+compiling 
    (compiler-typecase (person-age p)
                       (fixnum 'ok)
                       (else 'wrong))
    (test-assert (= 33 (person-age p))))

  )

;;; test by megane (#899):

(define-record-type foo
  (make-foo bar)
  foo?
  (bar foo-bar foo-bar-set!))

(display (make-foo 1))
(newline)


;;; (#943)

(defstruct bar943 
  ((a 100) : fixnum)
  (b : fixnum))

(define (create-bar943 a)
  (let ((b (make-bar943 a: a b: 42)))
    (print "(bar943-a b) " (bar943-a b))
    (print "(bar943-b b) " (bar943-b b))
    b))

(define x (create-bar943 1))

(test-assert (eq? 1 (bar943-a x)))
(test-assert (eq? 42 (bar943-b x)))

(module
 m1
 ()
 (import scheme
         (chicken base)
         (only typed-records defstruct))

 (defstruct ds-m*
   ((b 1) : number)))