mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
361553b49d
* module/srfi/srfi-9.scm: Add 2013 copyright date. * test-suite/tests/srfi-9.test: Adapt to recent error reporting improvements to procedures defined by 'define-tagged-inlinable'.
771 lines
26 KiB
Scheme
771 lines
26 KiB
Scheme
;;;; 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))))))))
|
||
|
||
|
||
(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))))))
|
||
|
||
|
||
(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:
|