mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source
This commit is contained in:
Mark H Weaver 2012-11-09 23:09:38 -05:00
commit ad84cc8b84
3 changed files with 288 additions and 134 deletions
Download patch file Download diff file Expand all files Collapse all files

44
module/srfi/srfi-9.scm
View file

@ -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

4
module/srfi/srfi-9/gnu.scm
View file

@ -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) ()