;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
+;; 2013, 2014 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
;; <predicate name>
;; <field spec> ...)
;;
-;; <field spec> -> (<field tag> <accessor name>)
-;; -> (<field tag> <accessor name> <modifier name>)
+;; <field spec> -> (<field tag> <getter name>)
+;; -> (<field tag> <getter name> <setter name>)
;;
;; <field tag> -> <identifier>
;; <... name> -> <identifier>
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
+ #:use-module (system base ck)
#:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+ (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time. This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define-syntax-rule (%%on-error err) err)
+
+(define %%type #f) ; a private syntax literal
+(define-syntax getter-type
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%type s))))
-(define-syntax define-inlinable
+(define %%index #f) ; a private syntax literal
+(define-syntax getter-index
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%index s))))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax getter-copier
+ (syntax-rules (quote)
+ ((_ s 'getter 'err)
+ (getter (%%on-error err) %%copier s))))
+
+(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
'-procedure)))
(syntax-case x ()
- ((_ (name formals ...) body ...)
+ ((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...))))
body ...)
(define-syntax name
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (%%on-error key ...)
+ ((_ (%%on-error err) key s) #'(ck s 'value)) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
args ...))
+ ((_ a (... ...))
+ (syntax-violation 'name "Wrong number of arguments" x))
(_
(identifier? x)
#'proc-name))))))))))
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
-(define-syntax define-record-type
+(define-syntax-rule (throw-bad-struct s who)
+ (let ((s* s))
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s*)
+ (list s*))))
+
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-set-fields)))
+
+(define-syntax %%set-fields
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type-name (getter-id ...) check? s (getter expr) ...)
+ (every identifier? #'(getter ...))
+ (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+ (getter+exprs #'((getter expr) ...))
+ (nfields (length #'(getter-id ...))))
+ (define (lookup id default-expr)
+ (let ((results
+ (filter (lambda (g+e)
+ (free-identifier=? id (car g+e)))
+ getter+exprs)))
+ (case (length results)
+ ((0) default-expr)
+ ((1) (cadar results))
+ (else (syntax-violation
+ copier-name "duplicate getter" x id)))))
+ (for-each (lambda (id)
+ (or (find (lambda (getter-id)
+ (free-identifier=? id getter-id))
+ #'(getter-id ...))
+ (syntax-violation
+ copier-name "unknown getter" x id)))
+ #'(getter ...))
+ (with-syntax ((unsafe-expr
+ #`(let ((new (allocate-struct type-name #,nfields)))
+ #,@(map (lambda (getter index)
+ #`(struct-set!
+ new
+ #,index
+ #,(lookup getter
+ #`(struct-ref s #,index))))
+ #'(getter-id ...)
+ (iota nfields))
+ new)))
+ (if (syntax->datum #'check?)
+ #`(if (eq? (struct-vtable s) type-name)
+ unsafe-expr
+ (throw-bad-struct
+ s '#,(datum->syntax #'here copier-name)))
+ #'unsafe-expr)))))))
+
+(define-syntax %define-record-type
(lambda (x)
(define (field-identifiers field-specs)
- (syntax-case field-specs ()
- (()
- '())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor) #'(name))
- ((name accessor modifier) #'(name))))
- ((field-spec rest ...)
- (append (field-identifiers #'(field-spec))
- (field-identifiers #'(rest ...))))))
-
- (define (field-indices fields)
- (fold (lambda (field result)
- (let ((i (if (null? result)
- 0
- (+ 1 (cdar result)))))
- (alist-cons field i result)))
- '()
- fields))
-
- (define (constructor type-name constructor-spec indices)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'name)
+ ((name getter setter) #'name)))
+ field-specs))
+
+ (define (getter-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'getter)
+ ((name getter setter) #'getter)))
+ field-specs))
+
+ (define (constructor form type-name constructor-spec field-ids)
(syntax-case constructor-spec ()
((ctor field ...)
- (let ((field-count (length indices))
- (ctor-args (map (lambda (field)
- (cons (syntax->datum field) field))
- #'(field ...))))
+ (every identifier? #'(field ...))
+ (let ((slots (map (lambda (field)
+ (or (list-index (lambda (x)
+ (free-identifier=? x field))
+ field-ids)
+ (syntax-violation
+ (syntax-case form ()
+ ((macro . args)
+ (syntax->datum #'macro)))
+ "unknown field in constructor spec"
+ form field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
- (make-struct #,type-name 0
- #,@(unfold
- (lambda (field-num)
- (>= field-num field-count))
- (lambda (field-num)
- (let* ((name
- (car (find (lambda (f+i)
- (= (cdr f+i) field-num))
- indices)))
- (arg (assq name ctor-args)))
- (if (pair? arg)
- (cdr arg)
- #'#f)))
- 1+
- 0)))))))
-
- (define (accessors type-name field-specs indices)
- (syntax-case field-specs ()
- (()
- #'())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`((define-inlinable (accessor s)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-ref s index)
- (throw 'wrong-type-arg 'accessor
- "Wrong type argument: ~S" (list s)
- (list s)))))))
- ((name accessor modifier)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`(#,@(accessors type-name #'((name accessor)) indices)
- (define-inlinable (modifier s val)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-set! s index val)
- (throw 'wrong-type-arg 'modifier
- "Wrong type argument: ~S" (list s)
- (list s)))))))))
- ((field-spec rest ...)
- #`(#,@(accessors type-name #'(field-spec) indices)
- #,@(accessors type-name #'(rest ...) indices)))))
+ (let ((s (allocate-struct #,type-name #,(length field-ids))))
+ #,@(map (lambda (arg slot)
+ #`(struct-set! s #,slot #,arg))
+ #'(field ...) slots)
+ s))))))
+
+ (define (getters type-name getter-ids copier-id)
+ (map (lambda (getter index)
+ #`(define-tagged-inlinable
+ ((%%type #,type-name)
+ (%%index #,index)
+ (%%copier #,copier-id))
+ (#,getter s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s #,index)
+ (throw-bad-struct s '#,getter))))
+ getter-ids
+ (iota (length getter-ids))))
+
+ (define (copier type-name getter-ids copier-id)
+ #`(define-syntax-rule
+ (#,copier-id check? s (getter expr) (... ...))
+ (%%set-fields #,type-name #,getter-ids
+ check? s (getter expr) (... ...))))
+
+ (define (setters type-name field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s #,index val)
+ (throw-bad-struct s 'setter))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (functional-setters copier-id field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (#,copier-id #t s (getter val))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (record-layout immutable? count)
+ ;; Mutability is expressed on the record level; all structs in the
+ ;; future will be mutable.
+ (string-concatenate (make-list count "pw")))
(syntax-case x ()
- ((_ type-name constructor-spec predicate-name field-spec ...)
- (let* ((fields (field-identifiers #'(field-spec ...)))
- (field-count (length fields))
- (layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields)))
+ ((_ immutable? form type-name constructor-spec predicate-name
+ field-spec ...)
+ (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))
+ (immutable? (syntax->datum #'immutable?))
+ (layout (record-layout immutable? field-count))
(ctor-name (syntax-case #'constructor-spec ()
- ((ctor args ...) #'ctor))))
+ ((ctor args ...) #'ctor)))
+ (copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'type-name #'constructor-spec indices)
+ #,(constructor #'form #'type-name #'constructor-spec field-ids)
(define type-name
(let ((rtd (make-struct/no-tail
'#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer
'type-name
- '#,fields)))
+ '#,field-ids)))
(set-struct-vtable-name! rtd 'type-name)
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,@(accessors #'type-name #'(field-spec ...) indices)))))))
+ #,@(getters #'type-name getter-ids copier-id)
+ #,(copier #'type-name getter-ids copier-id)
+ #,@(if immutable?
+ (functional-setters copier-id #'(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 (define-record-type name ctor pred fields ...)
+ name ctor pred fields ...))
;;; srfi-9.scm ends here
HCoop / bpt / guile.git / blobdiff