diff options
Diffstat (limited to 'test-suite/tests/srfi-9.test')
-rw-r--r-- | test-suite/tests/srfi-9.test | 771 |
1 files changed, 771 insertions, 0 deletions
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test new file mode 100644 index 000000000..e1812bfbf --- /dev/null +++ b/test-suite/tests/srfi-9.test @@ -0,0 +1,771 @@ +;;;; 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: |