summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/srfi/srfi-9.scm44
-rw-r--r--module/srfi/srfi-9/gnu.scm4
-rw-r--r--test-suite/tests/srfi-9.test396
3 files changed, 299 insertions, 145 deletions
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 1dd132a7b..de4945952 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -205,8 +205,10 @@
(let ((name (syntax->datum field)))
(or (memq name field-names)
(syntax-violation
- 'define-record-type
- "unknown field in constructor-spec"
+ (syntax-case form ()
+ ((macro . args)
+ (syntax->datum #'macro)))
+ "unknown field in constructor spec"
form field))
(cons name field)))
#'(field ...))))
@@ -262,9 +264,30 @@
(string-concatenate (make-list count desc))))
(syntax-case x ()
- ((_ immutable? type-name constructor-spec predicate-name
+ ((_ immutable? form type-name constructor-spec predicate-name
field-spec ...)
- (boolean? (syntax->datum #'immutable?))
+ (let ()
+ (define (syntax-error message subform)
+ (syntax-violation (syntax-case #'form ()
+ ((macro . args) (syntax->datum #'macro)))
+ message #'form subform))
+ (and (boolean? (syntax->datum #'immutable?))
+ (or (identifier? #'type-name)
+ (syntax-error "expected type name" #'type-name))
+ (syntax-case #'constructor-spec ()
+ ((ctor args ...)
+ (every identifier? #'(ctor args ...))
+ #t)
+ (_ (syntax-error "invalid constructor spec"
+ #'constructor-spec)))
+ (or (identifier? #'predicate-name)
+ (syntax-error "expected predicate name" #'predicate-name))
+ (every (lambda (spec)
+ (syntax-case spec ()
+ ((field getter) #t)
+ ((field getter setter) #t)
+ (_ (syntax-error "invalid field spec" spec))))
+ #'(field-spec ...))))
(let* ((field-ids (field-identifiers #'(field-spec ...)))
(getter-ids (getter-identifiers #'(field-spec ...)))
(field-count (length field-ids))
@@ -275,7 +298,7 @@
((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor x #'type-name #'constructor-spec field-names)
+ #,(constructor #'form #'type-name #'constructor-spec field-names)
(define type-name
(let ((rtd (make-struct/no-tail
@@ -296,9 +319,16 @@
#,(copier #'type-name getter-ids copier-id)
#,@(if immutable?
(functional-setters copier-id #'(field-spec ...))
- (setters #'type-name #'(field-spec ...)))))))))
+ (setters #'type-name #'(field-spec ...))))))
+ ((_ immutable? form . rest)
+ (syntax-violation
+ (syntax-case #'form ()
+ ((macro . args) (syntax->datum #'macro)))
+ "invalid record definition syntax"
+ #'form)))))
(define-syntax-rule (define-record-type name ctor pred fields ...)
- (%define-record-type #f name ctor pred fields ...))
+ (%define-record-type #f (define-record-type name ctor pred fields ...)
+ name ctor pred fields ...))
;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index fa091fe86..4f3a6634c 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -34,7 +34,9 @@
(struct-set! type vtable-index-printer thunk))
(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
- ((@@ (srfi srfi-9) %define-record-type) #t name ctor pred fields ...))
+ ((@@ (srfi srfi-9) %define-record-type)
+ #t (define-immutable-record-type name ctor pred fields ...)
+ name ctor pred fields ...))
(define-syntax-rule (set-field (getter ...) s expr)
(%set-fields #t (set-field (getter ...) s expr) ()
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index a5179e26e..4935148b3 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -118,7 +118,10 @@
(pass-if-exception "set-field on number" exception:wrong-type-arg
(set-field (foo-x bar-j) 4 3))
- (pass-if "set-field with unknown first getter"
+ (pass-if-equal "set-field with unknown first getter"
+ '(syntax-error set-fields "unknown getter"
+ (set-field (blah) s 3)
+ blah)
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
@@ -126,12 +129,12 @@
#:env (current-module))
#f)
(lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(syntax-error set-fields "unknown getter"
- (set-field (blah) s 3)
- blah)))))
+ (list key whom what form subform))))
- (pass-if "set-field with unknown second getter"
+ (pass-if-equal "set-field with unknown second getter"
+ '(syntax-error set-fields "unknown getter"
+ (set-field (bar-j blah) s 3)
+ blah)
(catch 'syntax-error
(lambda ()
(compile '(let ((s (make-bar (make-foo 5) 2)))
@@ -139,10 +142,7 @@
#:env (current-module))
#f)
(lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(syntax-error set-fields "unknown getter"
- (set-field (bar-j blah) s 3)
- blah)))))
+ (list key whom what form subform))))
(pass-if "set-fields"
(let ((s (make-foo (make-bar 1 2))))
@@ -167,7 +167,10 @@
((foo-x bar-j) 3)
((foo-z) 'bar)))
- (pass-if "set-fields with unknown first getter"
+ (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)))
@@ -175,12 +178,12 @@
#:env (current-module))
#f)
(lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(syntax-error set-fields "unknown getter"
- (set-fields s ((bar-i foo-x) 1) ((blah) 3))
- blah)))))
+ (list key whom what form subform))))
- (pass-if "set-fields with unknown second getter"
+ (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)))
@@ -188,12 +191,15 @@
#:env (current-module))
#f)
(lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(syntax-error set-fields "unknown getter"
- (set-fields s ((bar-i foo-x) 1) ((blah) 3))
- blah)))))
-
- (pass-if "set-fields with duplicate field path"
+ (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)))
@@ -204,15 +210,16 @@
#:env (current-module))
#f)
(lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(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))))))
-
- (pass-if "set-fields with one path as a prefix of another"
+ (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)))
@@ -223,14 +230,7 @@
#:env (current-module))
#f)
(lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(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)))))))
+ (list key whom what form subform)))))
(with-test-prefix "side-effecting arguments"
@@ -489,110 +489,232 @@
(equal? p (make-person 30 "foo@example.com"
(make-address "Foo" "Paris" "France")))))))
- (pass-if "set-fields with unknown first getter"
- (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))
-
- (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)
- (equal? (list key whom what form subform)
- '(syntax-error set-fields "unknown getter"
- (set-fields s ((bar-i foo-x) 1) ((blah) 3))
- blah))))))
-
- (pass-if "set-fields with unknown second getter"
- (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))
-
- (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)
- (equal? (list key whom what form subform)
- '(syntax-error set-fields "unknown getter"
- (set-fields s ((bar-i foo-x) 1) ((blah) 3))
- blah))))))
-
- (pass-if "set-fields with duplicate field path"
- (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))
-
- (catch 'syntax-error
- (lambda ()
- (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (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)))
- #:env (current-module))
- #f)
- (lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(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)))))))
-
- (pass-if "set-fields with one path as a prefix of another"
- (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))
-
- (catch 'syntax-error
- (lambda ()
- (compile '(let ((s (make-bar (make-foo 5) 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)))
- #:env (current-module))
- #f)
- (lambda (key whom what src form subform)
- (equal? (list key whom what form subform)
- '(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)))))))))
+ ((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))))))
+
+
+(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"