[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Functional record "setters", a different approach
From: |
Mark H Weaver |
Subject: |
Functional record "setters", a different approach |
Date: |
Wed, 11 Apr 2012 02:59:11 -0400 |
Hello all,
Attached below is my preliminary attempt at functional record "setters".
These macros generate optimal code to generate a modified copy of an
existing tree of srfi-9 records, with any number of elements modified at
once.
I confess that this task was more difficult than I had anticipated, and
it required a different approach than Ludovic had taken, because
functional single-field-setters cannot be used to build an optimal
functional multi-field-setter.
Instead, each record type defines a '%%<TYPE-NAME>-modified-copy' macro
that copies a record but with an arbitrary number of modified fields.
This is the basis for the exported macros 'modified-copy' and
'modified-copy-nocheck' that supports arbitrarily nested records.
As Ludovic warned, this requires knowledge of the record types at
expansion time. To accomplish this, I enhanced srfi-9's private
'define-inlinable' macro to allow an arbitrary number of key/value pairs
to be associated with the generated macro. The new macro is called
'define-tagged-inlinable', and it's used like this:
(define-tagged-inlinable (key value) ... (name formals ...) body ...)
where each 'key' is a private literal identifier in (srfi srfi-9).
Currently, the keys '%%type', '%%index', and '%%copier' are associated
with each getter, which causes the getter macro to support additional
rules:
(<GETTER> () %%copier) ==> %%<TYPE-NAME>-modified-copy
(<GETTER> () %%type) ==> %%<TYPE-NAME>
(<GETTER> () %%index) ==> <INTEGER>
Since the keys are private to (srfi srfi-9), users cannot use these
private rules without accessing srfi-9's private symbols.
While I was at it, I incorporated Andy's suggestions
(accessors/modifiers => getters/setters, throw-bad-struct), and made
various other simplifications and improvements to the existing srfi-9
code, while being careful to remain ABI compatible with .go files
compiled with earlier versions of Guile 2.
Anyway, enough about the internals.
The public interface I've created is quite a bit different than what
we've been discussing so far. I'm open to changing it, but here's what
the attached patch currently exports from (srfi srfi-9 gnu):
(modified-copy <struct-expr> (<field-path> <expr>) ...)
(modified-copy-nocheck <struct-expr> (<field-path> <expr>) ...)
where <field-path> is of the form (<field> ...)
These macros can be used on _any_ srfi-9 record, not just ones specially
declared as immutable. In fact, I have not yet gotten around to
creating immutable records (with "pr" layout), though I would like to
add this soon. However, I see no reason not to support 'modified-copy'
on mutable records as well.
Here's an example session:
scheme@(guile-user)> ,use (srfi srfi-9)
scheme@(guile-user)> ,use (srfi srfi-9 gnu)
scheme@(guile-user)> (define-record-type :foo
(make-foo x)
foo?
(x get-x)
(y get-y set-y!))
scheme@(guile-user)> (define-record-type :bar
(make-bar i j)
bar?
(i get-i)
(j get-j set-j!))
scheme@(guile-user)> (define a (make-foo (make-bar 1 (make-foo 2))))
scheme@(guile-user)> a
$1 = #<:foo x: #<:bar i: 1 j: #<:foo x: 2 y: #f>> y: #f>
scheme@(guile-user)> (modified-copy a
((get-x get-i) 10)
((get-y) 14)
((get-x get-j get-y) 12))
$2 = #<:foo x: #<:bar i: 10 j: #<:foo x: 2 y: 12>> y: 14>
scheme@(guile-user)> ,opt (modified-copy-nocheck a
((get-x get-i) 10)
((get-y) 14)
((get-x get-j get-y) 12))
$3 = (let ((s a))
(make-struct/no-tail
:foo
(let ((s (struct-ref s 0)))
(make-struct/no-tail
:bar
10
(let ((s (struct-ref s 1)))
(make-struct/no-tail :foo (struct-ref s 0) 12))))
14))
scheme@(guile-user)> ,opt (modified-copy a
((get-x get-i) 10)
((get-y) 14)
((get-x get-j get-y) 12))
$4 = (let ((s a))
(if (eq? (struct-vtable s) :foo)
(make-struct/no-tail
:foo
(let ((s (struct-ref s 0)))
(if (eq? (struct-vtable s) :bar)
(make-struct/no-tail
:bar
10
(let ((s (struct-ref s 1)))
(if (eq? (struct-vtable s) :foo)
(make-struct/no-tail :foo (struct-ref s 0) 12)
((@@ (srfi srfi-9) throw-bad-struct)
s
'%%:foo-modified-copy))))
((@@ (srfi srfi-9) throw-bad-struct)
s
'%%:bar-modified-copy)))
14)
((@@ (srfi srfi-9) throw-bad-struct)
s
'%%:foo-modified-copy)))
scheme@(guile-user)>
Comments and suggestions solicited.
Mark
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 4b36ce3..866d28b 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -60,7 +60,7 @@
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
- #:export (define-record-type))
+ #:export-syntax (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
@@ -68,8 +68,26 @@
;; 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 %%type #f) ; a private syntax literal
+(define-syntax-rule (getter-type getter) (getter () %%type))
-(define-syntax define-inlinable
+(define %%index #f) ; a private syntax literal
+(define-syntax-rule (getter-index getter) (getter () %%index))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax-rule (getter-copier getter) (getter () %%copier))
+
+(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
@@ -77,7 +95,7 @@
'-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 ...))))
@@ -86,7 +104,8 @@
body ...)
(define-syntax name
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (key ...)
+ ((_ () key) #'value) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
@@ -114,6 +133,49 @@
"Wrong type argument: ~S" (list s)
(list s)))
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-modified-copy)))
+
+(define-syntax %%modified-copy
+ (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) ...)))
+ (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
+ #`(make-struct
+ type-name 0
+ #,@(map (lambda (getter index)
+ (lookup getter #`(struct-ref s #,index)))
+ #'(getter-id ...)
+ (iota (length #'(getter-id ...)))))))
+ (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)
@@ -123,29 +185,57 @@
((name getter setter) #'name)))
field-specs))
- (define (constructor type-name constructor-spec field-names)
+ (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-names)
(syntax-case constructor-spec ()
((ctor field ...)
- (let ((field-count (length field-names))
- (ctor-args (map (lambda (field)
- (cons (syntax->datum field) field))
- #'(field ...))))
+ (every identifier? #'(field ...))
+ (let ((ctor-args (map (lambda (field)
+ (let ((name (syntax->datum field)))
+ (or (memq name field-names)
+ (syntax-violation
+ 'define-record-type
+ "unknown field in constructor-spec"
+ form field))
+ (cons name field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
#,@(map (lambda (name)
(assq-ref ctor-args name))
field-names)))))))
- (define (getters type-name field-specs)
- (map (lambda (field-spec index)
- (syntax-case field-spec ()
- ((name getter . _)
- #`(define-inlinable (getter s)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-ref s #,index)
- (throw-bad-struct s 'getter))))))
- field-specs
- (iota (length field-specs))))
+ (define (copier type-name getter-ids copier-id)
+ (with-syntax ((type-name type-name)
+ (getter-ids getter-ids)
+ ;; FIXME: Using 'copier-id' here (without stripping
+ ;; its wrap) fails when 'define-record-type' is used
+ ;; at non-top-level. Why?
+ (copier-id (datum->syntax
+ #'here (syntax->datum copier-id))))
+ #'(define-syntax-rule
+ (copier-id check? s (getter expr) (... ...))
+ (%%modified-copy type-name getter-ids
+ check? s (getter expr) (... ...)))))
+
+ (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 (setters type-name field-specs)
(filter-map (lambda (field-spec index)
@@ -161,14 +251,16 @@
(syntax-case x ()
((_ type-name constructor-spec predicate-name field-spec ...)
- (let* ((fields (field-identifiers #'(field-spec ...)))
- (field-count (length fields))
+ (let* ((field-ids (field-identifiers #'(field-spec ...)))
+ (getter-ids (getter-identifiers #'(field-spec ...)))
+ (field-count (length field-ids))
(layout (string-concatenate (make-list field-count "pw")))
- (field-names (map syntax->datum fields))
+ (field-names (map syntax->datum field-ids))
(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 field-names)
+ #,(constructor x #'type-name #'constructor-spec field-names)
(define type-name
(let ((rtd (make-struct/no-tail
@@ -176,7 +268,7 @@
'#,(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))
@@ -185,7 +277,9 @@
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,@(getters #'type-name #'(field-spec ...))
- #,@(setters #'type-name #'(field-spec ...))))))))
+ #,@(getters #'type-name getter-ids copier-id)
+ #,@(setters #'type-name #'(field-spec ...))
+ #,(copier #'type-name getter-ids copier-id)
+ ))))))
;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 30c101b..d9c24a1 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-9
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 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
@@ -23,8 +23,63 @@
;;; Code:
(define-module (srfi srfi-9 gnu)
- #:export (set-record-type-printer!))
+ #:use-module (srfi srfi-1)
+ #:export (set-record-type-printer!)
+ #:export-syntax (modified-copy modified-copy-nocheck))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk))
+
+(define-syntax-rule (modified-copy s . rest)
+ (%modified-copy #t s . rest))
+
+(define-syntax-rule (modified-copy-nocheck s . rest)
+ (%modified-copy #f s . rest))
+
+(define-syntax %modified-copy
+ (lambda (x)
+ (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
+ (getter-index #'(@@ (srfi srfi-9) getter-index))
+ (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+ (syntax-case x ()
+ ((_ check? s)
+ #'s)
+ ((_ check? s (() e))
+ #'e)
+ ((_ check? struct-expr ((getter . rest) expr) ...)
+ ;;
+ ;; FIXME: Improve compile-time error reporting:
+ ;; 1. report an error if any getter-path is a
+ ;; prefix of any other getter-path.
+ ;; 2. report an error if the initial getters
+ ;; do not all belong to the same record type.
+ ;;
+ ;; forest : (tree ...)
+ ;; tree : (getter (rest . expr) ...)
+ (let ((forest
+ (fold (lambda (g r e forest)
+ (cond ((find (lambda (tree)
+ (free-identifier=? g (car tree)))
+ forest)
+ => (lambda (tree)
+ (cons (cons g (cons (cons r e)
+ (cdr tree)))
+ (delq tree forest))))
+ (else (cons (list g (cons r e))
+ forest))))
+ '()
+ #'(getter ...)
+ #'(rest ...)
+ #'(expr ...))))
+ #`(let ((s struct-expr))
+ ((getter-copier #,(caar forest))
+ check?
+ s
+ #,@(map (lambda (tree)
+ (with-syntax (((getter (rest . expr) ...) tree))
+ #'(getter (%modified-copy
+ check?
+ (struct-ref s (getter-index getter))
+ (rest expr) ...))))
+ forest)))))))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 321fe16..d0668db 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -29,7 +29,7 @@
(x get-x) (y get-y set-y!))
(define-record-type :bar (make-bar i j) bar?
- (i get-i) (i get-j set-j!))
+ (i get-i) (j get-j set-j!))
(define f (make-foo 1))
(set-y! f 2)
- Functional record "setters", a different approach,
Mark H Weaver <=
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/04/11
- Re: Functional record "setters", a different approach, Ludovic Courtès, 2012/04/11
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/04/12
- Re: Functional record "setters", a different approach, Thien-Thi Nguyen, 2012/04/12
- Re: Functional record "setters", a different approach, Ludovic Courtès, 2012/04/12
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/04/12
- Re: Functional record "setters", a different approach, Ludovic Courtès, 2012/04/13
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/04/13