;;;; 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 Free Software Foundation, Inc.
+;;;; 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
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile))
- #:use-module (srfi srfi-9))
+ #: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 get-x) (y get-y set-y!))
+(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 get-i) (i get-j set-j!))
+(define-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j!))
(define f (make-foo 1))
-(set-y! f 2)
+(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-pattern-unmatched
+ (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-pattern-unmatched
+ (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
(pass-if "fail number"
(eq? #f (foo? 123))))
-(with-test-prefix "accessor"
+(with-test-prefix "getter"
- (pass-if "get-x"
- (= 1 (get-x f)))
- (pass-if "get-y"
- (= 2 (get-y f)))
+ (pass-if "foo-x"
+ (= 1 (foo-x f)))
+ (pass-if "foo-y"
+ (= 2 (foo-y f)))
- (pass-if-exception "get-x on number" exception:wrong-type-arg
- (get-x 999))
- (pass-if-exception "get-y on number" exception:wrong-type-arg
- (get-y 999))
+ (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 "get-x on bar" exception:wrong-type-arg
- (get-x b))
- (pass-if-exception "get-y on bar" exception:wrong-type-arg
- (get-y b)))
+ (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 "modifier"
+(with-test-prefix "setter"
- (pass-if "set-y!"
- (set-y! f #t)
- (eq? #t (get-y f)))
+ (pass-if "set-foo-y!"
+ (set-foo-y! f #t)
+ (eq? #t (foo-y f)))
- (pass-if-exception "set-y! on number" exception:wrong-type-arg
- (set-y! 999 #t))
+ (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-y! on bar" exception:wrong-type-arg
- (set-y! b 99)))
+ (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 "construction"
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
- (= (frotz-b frotz) 2)))))
+ (= (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-constructor"
(equal? ((record-constructor :foo) 1)
(make-foo 1))))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; eval: (put 'set-fields 'scheme-indent-function 1)
+;;; End:
HCoop / bpt / guile.git / blobdiff