diff options
author | Mark H Weaver <mhw@netris.org> | 2012-11-09 23:09:38 -0500 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2012-11-09 23:09:38 -0500 |
commit | ad84cc8b84c8ee0b4920e7a97b1e6ecbbbafab29 (patch) | |
tree | 0aa5d8eb06a3e5dbbc81154d7fa6e2e91951b630 /module/srfi | |
parent | db1f46667c7a3a63e4230ca12523046f0cb602f5 (diff) | |
parent | f31a0762328b9cffa328ce1540ceaa6f1497e083 (diff) | |
download | guile-ad84cc8b84c8ee0b4920e7a97b1e6ecbbbafab29.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-9.scm | 44 | ||||
-rw-r--r-- | module/srfi/srfi-9/gnu.scm | 4 |
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) () |