summaryrefslogtreecommitdiff
path: root/module/srfi
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2012-11-09 23:09:38 -0500
committerMark H Weaver <mhw@netris.org>2012-11-09 23:09:38 -0500
commitad84cc8b84c8ee0b4920e7a97b1e6ecbbbafab29 (patch)
tree0aa5d8eb06a3e5dbbc81154d7fa6e2e91951b630 /module/srfi
parentdb1f46667c7a3a63e4230ca12523046f0cb602f5 (diff)
parentf31a0762328b9cffa328ce1540ceaa6f1497e083 (diff)
downloadguile-ad84cc8b84c8ee0b4920e7a97b1e6ecbbbafab29.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Diffstat (limited to 'module/srfi')
-rw-r--r--module/srfi/srfi-9.scm44
-rw-r--r--module/srfi/srfi-9/gnu.scm4
2 files changed, 40 insertions, 8 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) ()