[bpt/guile.git] / test-suite / tests / srfi-9.test

;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 2012,
;;;;   2013 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (test-suite test-numbers)
  #:use-module (test-suite lib)
  #:use-module ((system base compile) #:select (compile))
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu))


(define-record-type :qux (make-qux) qux?)

(define-record-type :foo (make-foo x) foo?
  (x foo-x)
  (y foo-y set-foo-y!)
  (z foo-z set-foo-z!))

(define-record-type :bar (make-bar i j) bar?
  (i bar-i)
  (j bar-j set-bar-j!))

(define f (make-foo 1))
(set-foo-y! f 2)

(define b (make-bar 123 456))

(define exception:syntax-error-wrong-num-args
  (cons 'syntax-error "Wrong number of arguments"))

(with-test-prefix "constructor"

  ;; Constructors are defined using `define-integrable', meaning that direct
  ;; calls as in `(make-foo)' lead to a compile-time psyntax error, hence the
  ;; distinction below.

  (pass-if-exception "foo 0 args (inline)" exception:syntax-error-wrong-num-args
     (compile '(make-foo) #:env (current-module)))
  (pass-if-exception "foo 2 args (inline)" exception:syntax-error-wrong-num-args
     (compile '(make-foo 1 2) #:env (current-module)))

  (pass-if-exception "foo 0 args" exception:wrong-num-args
     (let ((make-foo make-foo))
       (make-foo)))
  (pass-if-exception "foo 2 args" exception:wrong-num-args
     (let ((make-foo make-foo))
       (make-foo 1 2))))

(with-test-prefix "predicate"

  (pass-if "pass"
     (foo? f))
  (pass-if "fail wrong record type"
     (eq? #f (foo? b)))
  (pass-if "fail number"
     (eq? #f (foo? 123))))

(with-test-prefix "getter"

  (pass-if "foo-x"
     (= 1 (foo-x f)))
  (pass-if "foo-y"
     (= 2 (foo-y f)))

  (pass-if-exception "foo-x on number" exception:wrong-type-arg
     (foo-x 999))
  (pass-if-exception "foo-y on number" exception:wrong-type-arg
     (foo-y 999))

  ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  (pass-if-exception "foo-x on bar" exception:wrong-type-arg
     (foo-x b))
  (pass-if-exception "foo-y on bar" exception:wrong-type-arg
     (foo-y b)))

(with-test-prefix "setter"

  (pass-if "set-foo-y!"
     (set-foo-y! f #t)
     (eq? #t (foo-y f)))

  (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg
     (set-foo-y! 999 #t))

  ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
  (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg
     (set-foo-y! b 99)))

(with-test-prefix "functional setters"

  (pass-if "set-field"
    (let ((s (make-foo (make-bar 1 2))))
      (and (equal? (set-field s (foo-x bar-j) 3)
                   (make-foo (make-bar 1 3)))
           (equal? (set-field s (foo-z) 'bar)
                   (let ((s2 (make-foo (make-bar 1 2))))
                     (set-foo-z! s2 'bar)
                     s2))
           (equal? s (make-foo (make-bar 1 2))))))

  (pass-if-exception "set-field on wrong struct type" exception:wrong-type-arg
    (let ((s (make-bar (make-foo 5) 2)))
      (set-field s (foo-x bar-j) 3)))

  (pass-if-exception "set-field on number" exception:wrong-type-arg
    (set-field 4 (foo-x bar-j) 3))

  (pass-if-equal "set-field with unknown first getter"
      '(syntax-error set-fields "unknown getter"
                     (set-field s (blah) 3)
                     blah)
    (catch 'syntax-error
      (lambda ()
        (compile '(let ((s (make-bar (make-foo 5) 2)))
                    (set-field s (blah) 3))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "set-field with unknown second getter"
      '(syntax-error set-fields "unknown getter"
                     (set-field s (bar-j blah) 3)
                     blah)
    (catch 'syntax-error
      (lambda ()
        (compile '(let ((s (make-bar (make-foo 5) 2)))
                    (set-field s (bar-j blah) 3))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if "set-fields"
    (let ((s (make-foo (make-bar 1 2))))
      (and (equal? (set-field s (foo-x bar-j) 3)
                   (make-foo (make-bar 1 3)))
           (equal? (set-fields s
                     ((foo-x bar-j) 3)
                     ((foo-z) 'bar))
                   (let ((s2 (make-foo (make-bar 1 3))))
                     (set-foo-z! s2 'bar)
                     s2))
           (equal? s (make-foo (make-bar 1 2))))))

  (pass-if-exception "set-fields on wrong struct type" exception:wrong-type-arg
    (let ((s (make-bar (make-foo 5) 2)))
      (set-fields 4
        ((foo-x bar-j) 3)
        ((foo-y) 'bar))))

  (pass-if-exception "set-fields on number" exception:wrong-type-arg
    (set-fields 4
      ((foo-x bar-j) 3)
      ((foo-z) 'bar)))

  (pass-if-equal "set-fields with unknown first getter"
      '(syntax-error set-fields "unknown getter"
                     (set-fields s ((bar-i foo-x) 1) ((blah) 3))
                     blah)
    (catch 'syntax-error
      (lambda ()
        (compile '(let ((s (make-bar (make-foo 5) 2)))
                    (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "set-fields with unknown second getter"
      '(syntax-error set-fields "unknown getter"
                     (set-fields s ((bar-i foo-x) 1) ((blah) 3))
                     blah)
    (catch 'syntax-error
      (lambda ()
        (compile '(let ((s (make-bar (make-foo 5) 2)))
                    (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "set-fields with duplicate field path"
      '(syntax-error set-fields "duplicate field path"
                     (set-fields s
                       ((bar-i foo-x) 1)
                       ((bar-i foo-z) 2)
                       ((bar-i foo-x) 3))
                     (bar-i foo-x))
    (catch 'syntax-error
      (lambda ()
        (compile '(let ((s (make-bar (make-foo 5) 2)))
                    (set-fields s
                      ((bar-i foo-x) 1)
                      ((bar-i foo-z) 2)
                      ((bar-i foo-x) 3)))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "set-fields with one path as a prefix of another"
      '(syntax-error set-fields
                     "one field path is a prefix of another"
                     (set-fields s
                       ((bar-i foo-x) 1)
                       ((bar-i foo-z) 2)
                       ((bar-i) 3))
                     (bar-i))
    (catch 'syntax-error
      (lambda ()
        (compile '(let ((s (make-bar (make-foo 5) 2)))
                    (set-fields s
                      ((bar-i foo-x) 1)
                      ((bar-i foo-z) 2)
                      ((bar-i) 3)))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform)))))

(with-test-prefix "side-effecting arguments"

  (pass-if "predicate"
    (let ((x 0))
      (and (foo? (begin (set! x (+ x 1)) f))
           (= x 1)))))

(with-test-prefix "non-toplevel"

  (define-record-type :frotz (make-frotz a b) frotz?
    (a frotz-a) (b frotz-b set-frotz-b!))

  (pass-if "construction"
    (let ((frotz (make-frotz 1 2)))
      (and (= (frotz-a frotz) 1)
           (= (frotz-b frotz) 2))))

  (with-test-prefix "functional setters"
    (let ()
      (define-record-type foo (make-foo x) foo?
        (x foo-x)
        (y foo-y set-foo-y!)
        (z foo-z set-foo-z!))

      (define-record-type :bar (make-bar i j) bar?
        (i bar-i)
        (j bar-j set-bar-j!))

      (pass-if "set-field"
        (let ((s (make-foo (make-bar 1 2))))
          (and (equal? (set-field s (foo-x bar-j) 3)
                       (make-foo (make-bar 1 3)))
               (equal? (set-field s (foo-z) 'bar)
                       (let ((s2 (make-foo (make-bar 1 2))))
                         (set-foo-z! s2 'bar)
                         s2))
               (equal? s (make-foo (make-bar 1 2)))))))

    (pass-if "set-fieldss "

      (let ((s (make-foo (make-bar 1 2))))
        (and (equal? (set-field s (foo-x bar-j) 3)
                     (make-foo (make-bar 1 3)))
             (equal? (set-fields s
                       ((foo-x bar-j) 3)
                       ((foo-z) 'bar))
                     (let ((s2 (make-foo (make-bar 1 3))))
                       (set-foo-z! s2 'bar)
                       s2))
             (equal? s (make-foo (make-bar 1 2))))))))

\f
(define-immutable-record-type :baz
  (make-baz x y z)
  baz?
  (x baz-x set-baz-x)
  (y baz-y set-baz-y)
  (z baz-z set-baz-z))

(define-immutable-record-type :address
  (make-address street city country)
  address?
  (street  address-street)
  (city    address-city)
  (country address-country))

(define-immutable-record-type :person
  (make-person age email address)
  person?
  (age     person-age)
  (email   person-email)
  (address person-address))

(with-test-prefix "define-immutable-record-type"

  (pass-if "get"
    (let ((b (make-baz 1 2 3)))
      (and (= (baz-x b) 1)
           (= (baz-y b) 2)
           (= (baz-z b) 3))))

  (pass-if "get non-inlined"
    (let ((b (make-baz 1 2 3)))
      (equal? (map (cute apply <> (list b))
                   (list baz-x baz-y baz-z))
              '(1 2 3))))

  (pass-if "set"
    (let* ((b0 (make-baz 1 2 3))
           (b1 (set-baz-x b0 11))
           (b2 (set-baz-y b1 22))
           (b3 (set-baz-z b2 33)))
      (and (= (baz-x b0) 1)
           (= (baz-x b1) 11) (= (baz-x b2) 11) (= (baz-x b3) 11)
           (= (baz-y b0) 2) (= (baz-y b1) 2)
           (= (baz-y b2) 22) (= (baz-y b3) 22)
           (= (baz-z b0) 3) (= (baz-z b1) 3) (= (baz-z b2) 3)
           (= (baz-z b3) 33))))

  (pass-if "set non-inlined"
    (let ((set (compose (cut set-baz-x <> 1)
                        (cut set-baz-y <> 2)
                        (cut set-baz-z <> 3))))
      (equal? (set (make-baz 0 0 0)) (make-baz 1 2 3))))

  (pass-if "set-field"
    (let ((p (make-person 30 "foo@example.com"
                          (make-address "Foo" "Paris" "France"))))
      (and (equal? (set-field p (person-address address-street) "Bar")
                   (make-person 30 "foo@example.com"
                                (make-address "Bar" "Paris" "France")))
           (equal? (set-field p (person-email) "bar@example.com")
                   (make-person 30 "bar@example.com"
                                (make-address "Foo" "Paris" "France")))
           (equal? p (make-person 30 "foo@example.com"
                                  (make-address "Foo" "Paris" "France"))))))

  (pass-if "set-fields"
    (let ((p (make-person 30 "foo@example.com"
                          (make-address "Foo" "Paris" "France"))))
      (and (equal? (set-fields p
                     ((person-email) "bar@example.com")
                     ((person-address address-country) "Catalonia")
                     ((person-address address-city) "Barcelona"))
                   (make-person 30 "bar@example.com"
                                (make-address "Foo" "Barcelona" "Catalonia")))
           (equal? (set-fields p
                     ((person-email) "bar@example.com")
                     ((person-age) 20))
                   (make-person 20 "bar@example.com"
                                (make-address "Foo" "Paris" "France")))
           (equal? p (make-person 30 "foo@example.com"
                                  (make-address "Foo" "Paris" "France"))))))

  (with-test-prefix "non-toplevel"

    (pass-if "get"
      (let ()
        (define-immutable-record-type bar
          (make-bar x y z)
          bar?
          (x bar-x)
          (y bar-y)
          (z bar-z set-bar-z))

        (let ((b (make-bar 1 2 3)))
          (and (= (bar-x b) 1)
               (= (bar-y b) 2)
               (= (bar-z b) 3)))))

    (pass-if "get non-inlined"
      (let ()
        (define-immutable-record-type bar
          (make-bar x y z)
          bar?
          (x bar-x)
          (y bar-y)
          (z bar-z set-bar-z))

        (let ((b (make-bar 1 2 3)))
          (equal? (map (cute apply <> (list b))
                       (list bar-x bar-y bar-z))
                  '(1 2 3)))))

    (pass-if "set"
      (let ()
        (define-immutable-record-type bar
          (make-bar x y z)
          bar?
          (x bar-x set-bar-x)
          (y bar-y set-bar-y)
          (z bar-z set-bar-z))

        (let* ((b0 (make-bar 1 2 3))
               (b1 (set-bar-x b0 11))
               (b2 (set-bar-y b1 22))
               (b3 (set-bar-z b2 33)))
          (and (= (bar-x b0) 1)
               (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11)
               (= (bar-y b0) 2) (= (bar-y b1) 2)
               (= (bar-y b2) 22) (= (bar-y b3) 22)
               (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3)
               (= (bar-z b3) 33)))))

    (pass-if "set non-inlined"
      (let ()
        (define-immutable-record-type bar
          (make-bar x y z)
          bar?
          (x bar-x set-bar-x)
          (y bar-y set-bar-y)
          (z bar-z set-bar-z))

        (let ((set (compose (cut set-bar-x <> 1)
                            (cut set-bar-y <> 2)
                            (cut set-bar-z <> 3))))
          (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3)))))

    (pass-if "set-field"
      (let ()
        (define-immutable-record-type address
          (make-address street city country)
          address?
          (street  address-street)
          (city    address-city)
          (country address-country))

        (define-immutable-record-type :person
          (make-person age email address)
          person?
          (age     person-age)
          (email   person-email)
          (address person-address))

        (let ((p (make-person 30 "foo@example.com"
                              (make-address "Foo" "Paris" "France"))))
          (and (equal? (set-field p (person-address address-street) "Bar")
                       (make-person 30 "foo@example.com"
                                    (make-address "Bar" "Paris" "France")))
               (equal? (set-field p (person-email) "bar@example.com")
                       (make-person 30 "bar@example.com"
                                    (make-address "Foo" "Paris" "France")))
               (equal? p (make-person 30 "foo@example.com"
                                      (make-address "Foo" "Paris" "France")))))))

    (pass-if "set-fields"
      (let ()
        (define-immutable-record-type address
          (make-address street city country)
          address?
          (street  address-street)
          (city    address-city)
          (country address-country))

        (define-immutable-record-type :person
          (make-person age email address)
          person?
          (age     person-age)
          (email   person-email)
          (address person-address))

        (let ((p (make-person 30 "foo@example.com"
                              (make-address "Foo" "Paris" "France"))))
          (and (equal? (set-fields p
                         ((person-email) "bar@example.com")
                         ((person-address address-country) "Catalonia")
                         ((person-address address-city) "Barcelona"))
                       (make-person 30 "bar@example.com"
                                    (make-address "Foo" "Barcelona" "Catalonia")))
               (equal? (set-fields p
                         ((person-email) "bar@example.com")
                         ((person-age) 20))
                       (make-person 20 "bar@example.com"
                                    (make-address "Foo" "Paris" "France")))
               (equal? p (make-person 30 "foo@example.com"
                                      (make-address "Foo" "Paris" "France")))))))

    (pass-if-equal "set-fields with unknown first getter"
        '(syntax-error set-fields "unknown getter"
                       (set-fields s ((bar-i foo-x) 1) ((blah) 3))
                       blah)
      (catch 'syntax-error
        (lambda ()
          (compile '(let ()
                      (define-immutable-record-type foo
                        (make-foo x)
                        foo?
                        (x foo-x)
                        (y foo-y set-foo-y)
                        (z foo-z set-foo-z))

                      (define-immutable-record-type :bar
                        (make-bar i j)
                        bar?
                        (i bar-i)
                        (j bar-j set-bar-j))

                      (let ((s (make-bar (make-foo 5) 2)))
                        (set-fields s ((bar-i foo-x) 1) ((blah) 3))))
                   #:env (current-module))
          #f)
        (lambda (key whom what src form subform)
          (list key whom what form subform))))

    (pass-if-equal "set-fields with unknown second getter"
        '(syntax-error set-fields "unknown getter"
                       (set-fields s ((bar-i foo-x) 1) ((blah) 3))
                       blah)
      (catch 'syntax-error
        (lambda ()
          (compile '(let ()
                      (define-immutable-record-type foo
                        (make-foo x)
                        foo?
                        (x foo-x)
                        (y foo-y set-foo-y)
                        (z foo-z set-foo-z))

                      (define-immutable-record-type :bar
                        (make-bar i j)
                        bar?
                        (i bar-i)
                        (j bar-j set-bar-j))

                      (let ((s (make-bar (make-foo 5) 2)))
                        (set-fields s ((bar-i foo-x) 1) ((blah) 3))))
                   #:env (current-module))
          #f)
        (lambda (key whom what src form subform)
          (list key whom what form subform))))

    (pass-if-equal "set-fields with duplicate field path"
        '(syntax-error set-fields "duplicate field path"
                       (set-fields s
                         ((bar-i foo-x) 1)
                         ((bar-i foo-z) 2)
                         ((bar-i foo-x) 3))
                       (bar-i foo-x))
      (catch 'syntax-error
        (lambda ()
          (compile '(let ()
                      (define-immutable-record-type foo
                        (make-foo x)
                        foo?
                        (x foo-x)
                        (y foo-y set-foo-y)
                        (z foo-z set-foo-z))

                      (define-immutable-record-type :bar
                        (make-bar i j)
                        bar?
                        (i bar-i)
                        (j bar-j set-bar-j))

                      (let ((s (make-bar (make-foo 5) 2)))
                        (set-fields s
                          ((bar-i foo-x) 1)
                          ((bar-i foo-z) 2)
                          ((bar-i foo-x) 3))))
                   #:env (current-module))
          #f)
        (lambda (key whom what src form subform)
          (list key whom what form subform))))

    (pass-if-equal "set-fields with one path as a prefix of another"
        '(syntax-error set-fields
                       "one field path is a prefix of another"
                       (set-fields s
                         ((bar-i foo-x) 1)
                         ((bar-i foo-z) 2)
                         ((bar-i) 3))
                       (bar-i))
      (catch 'syntax-error
        (lambda ()
          (compile '(let ()
                      (define-immutable-record-type foo
                        (make-foo x)
                        foo?
                        (x foo-x)
                        (y foo-y set-foo-y)
                        (z foo-z set-foo-z))

                      (define-immutable-record-type :bar
                        (make-bar i j)
                        bar?
                        (i bar-i)
                        (j bar-j set-bar-j))

                      (let ((s (make-bar (make-foo 5) 2)))
                        (set-fields s
                          ((bar-i foo-x) 1)
                          ((bar-i foo-z) 2)
                          ((bar-i) 3))))
                   #:env (current-module))
          #f)
        (lambda (key whom what src form subform)
          (list key whom what form subform))))

    (pass-if-equal "incompatible field paths"
        '(syntax-error set-fields
                       "\
field paths (bar-i bar-j) and (bar-i foo-x) require one object \
to belong to two different record types (bar and foo)"
                       (set-fields s
                         ((bar-i foo-x) 1)
                         ((bar-i bar-j) 2)
                         ((bar-j) 3))
                       #f)
      (catch 'syntax-error
        (lambda ()
          (compile '(let ()
                      (define-immutable-record-type foo
                        (make-foo x)
                        foo?
                        (x foo-x)
                        (y foo-y set-foo-y)
                        (z foo-z set-foo-z))

                      (define-immutable-record-type bar
                        (make-bar i j)
                        bar?
                        (i bar-i)
                        (j bar-j set-bar-j))

                      (let ((s (make-bar (make-foo 5) 2)))
                        (set-fields s
                          ((bar-i foo-x) 1)
                          ((bar-i bar-j) 2)
                          ((bar-j) 3))))
                   #:env (current-module))
          #f)
        (lambda (key whom what src form subform)
          (list key whom what form subform))))))

\f
(with-test-prefix "record type definition error reporting"

  (pass-if-equal "invalid type name"
      '(syntax-error define-immutable-record-type
                     "expected type name"
                     (define-immutable-record-type
                       (foobar x y)
                       foobar?
                       (x foobar-x)
                       (y foobar-y))
                     (foobar x y))
    (catch 'syntax-error
      (lambda ()
        (compile '(define-immutable-record-type
                    (foobar x y)
                    foobar?
                    (x foobar-x)
                    (y foobar-y))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "invalid constructor spec"
      '(syntax-error define-immutable-record-type
                     "invalid constructor spec"
                     (define-immutable-record-type :foobar
                       (make-foobar x y 3)
                       foobar?
                       (x foobar-x)
                       (y foobar-y))
                     (make-foobar x y 3))
    (catch 'syntax-error
      (lambda ()
        (compile '(define-immutable-record-type :foobar
                    (make-foobar x y 3)
                    foobar?
                    (x foobar-x)
                    (y foobar-y))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "invalid predicate name"
      '(syntax-error define-immutable-record-type
                     "expected predicate name"
                     (define-immutable-record-type :foobar
                       (foobar x y)
                       (x foobar-x)
                       (y foobar-y))
                     (x foobar-x))
    (catch 'syntax-error
      (lambda ()
        (compile '(define-immutable-record-type :foobar
                    (foobar x y)
                    (x foobar-x)
                    (y foobar-y))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

  (pass-if-equal "invalid field spec"
      '(syntax-error define-record-type
                     "invalid field spec"
                     (define-record-type :foobar
                       (make-foobar x y)
                       foobar?
                       (x)
                       (y foobar-y))
                     (x))
    (catch 'syntax-error
      (lambda ()
        (compile '(define-record-type :foobar
                    (make-foobar x y)
                    foobar?
                    (x)
                    (y foobar-y))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform))))

    (pass-if-equal "unknown field in constructor spec"
      '(syntax-error define-record-type
                     "unknown field in constructor spec"
                     (define-record-type :foobar
                       (make-foobar x z)
                       foobar?
                       (x foobar-x)
                       (y foobar-y))
                     z)
    (catch 'syntax-error
      (lambda ()
        (compile '(define-record-type :foobar
                    (make-foobar x z)
                    foobar?
                    (x foobar-x)
                    (y foobar-y))
                 #:env (current-module))
        #f)
      (lambda (key whom what src form subform)
        (list key whom what form subform)))))

(with-test-prefix "record compatibility"

  (pass-if "record?"
    (record? (make-foo 1)))

  (pass-if "record-constructor"
    (equal? ((record-constructor :foo) 1)
            (make-foo 1))))

;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'set-fields 'scheme-indent-function 1)
;;; End: