mailto:srfi-57@srfi.schemers.org.
See instructions
here to subscribe to the list. You can access previous messages via the
archive of the mailing list.
<command or definition>
-> <record type definition> ; addition to 7.1.6 in R5RS
<record type definition> -> (define-record-type <type clause>
<constructor clause>
<predicate clause>
<field clause> ...)
-> (define-record-type <type clause>
<constructor clause>)
-> (define-record-type <type clause>)
<type clause> -> <type name>
-> (<type name> <supertype name> ...)
<constructor clause> -> (<constructor name> <field label> ...)
-> <constructor name>
-> #f
<predicate clause> -> <predicate name>
-> #f
<field clause> -> (<field label> <accessor clause> <modifier clause>)
-> (<field label> <accessor clause>)
<accessor clause> -> <accessor name>
-> #f
<modifier clause> -> <modifier name>
-> #f
<field label> -> <identifier>
<... name> -> <identifier>
An instance of define-record-type is equivalent to the following:
<type name>,
obtained by appending the default order of each declared supertype
from left to right, followed by all field labels in order of first appearance in either the
<constructor clause> or the <field clause>s of
the <record type definition>, while dropping any repeated labels.
<type name> is bound to a macro, described below, that can be used to construct record
values by label.
<constructor clause> is
of the form (<constructor name> <field label> ...), then
<constructor name> is bound to a procedure that takes as many arguments as
there are <field label>s following it
and returns a new <type name> record.
Fields whose labels are listed with <type name> have the corresponding
argument as their initial value. The initial values of all other fields are unspecified.
If <constructor clause> is of the form <constructor name>,
the procedure
<constructor name> takes as many arguments as there are field labels
associated with <type name>, in the default order as defined above.
<predicate name>, is bound to a predicate procedure
that returns #t when given a record value that belongs to any subtype of
<type name>, and #f for any other
value.
<field clause>s. Fields that are not further specified in
a <field clause> of the record type or a
supertype are taken as immutable. Where present, <field
clause>s may provide additional information
on fields already listed in the constructor, or may
declare additional fields not appearing in the constructor.
A field clause of the form
(<field label> <accessor clause> <modifier
clause>)
declares a mutable field, while a field clause of the form
(<field label> <accessor clause>)
declares an immutable field.
A <field label> already declared in a supertype may
be listed again in a <field clause> of a
subtype, along with additional accessors or modifiers as desired. It
is an error for a subtype declaration to modify the mutability
attribute of an
inherited field. In addition, it is an error if more than one supertype
of a record type declares the same field label with different mutability attributes.
Field labels may be reused as the name of accessors or modifiers (a practice known as punning).
<accessor name> is bound to
a procedure that takes a
record belonging to any subtype of <type name>,
and returns the current value of the corresponding
field. It is an error to pass an accessor a value which is not a
record of the appropriate type.
<modifier name> is bound to
a procedure that takes a record belonging to any subtype of
<type name>,
and a value which becomes the new value of the corresponding field. The updated record
is returned (note that this differs from SRFI-9, in that we
require that a useful value be returned).
It is an error to pass a modifier a first argument which is not a record
of the appropriate type.
define-record-type is generative: each use creates a new record type that is distinct
from all existing types, including
other record types and Scheme's predefined types. Record-type definitions may only occur at top-level.
(define-record-type foo make-foo foo? (x foo-x)) (define-record-type bar make-bar bar? (x bar-x)) (define-record-type (foo-bar foo bar) (x foo-bar-x))Since any instance
fb of foo-bar is an instance of both
foo and bar, both foo-x and bar-x
will work on fb, returning the x field.
The accessor foo-bar-x will return the x
field of any instances of foo-bar or further subtypes of foo-bar
In the following example, two record types define the same accessor:
(define-record-type foo make-foo foo? (x foo-x)) (define-record-type (bar foo) make-bar bar? (x foo-x))As in any
define-... form, later bindings replace earlier bindings.
After the second declaration is executed,
foo-x will now work on instances of bar and not any
longer on instances of the supertype foo that are not also instances of bar.
(define-record-type point (make-point x y) point?
(x get-x set-x!)
(y get-y set-y!))
(define p (make-point 1 2))
(get-y p) ==> 2
(set-y! p 3)) ==> (point (x 1) (y 3))
(point? p) ==> #t
Note that the setter returns the updated record.
(define-record-type node (make-node left right)) (define-record-type leaf (make-leaf value))In these declarations, no predicates are bound. Also note that field labels listed in the constructor do not have to be repeated in the field clause list unless we want them to be mutable or we want to bind getters or setters.
(define-record-type monday) (define-record-type tuesday #f tuesday?)Here
monday has no declared constructor or predicate, while tuesday
has a predicate but no constructor.
(define-record-type node make-node #f
(left left #f)
(right right #f))
Here the constructor make-node has the default argument order and no predicate
is bound. Fields are mutable, but no setters are bound. Also note that field labels are
punned.
(define-record-type color make-color color? ; make-color takes default argument order
(hue hue set-hue!)) ; punning of field labels is allowed
(define-record-type (color-point color point) ; more than one supertype
(make-color-point x y hue)
color-point?
(info info)) ; field left undefined by constructor
(define cp (make-color-point 1 2 'green))
(color-point? cp) ==> #t
(point? cp) ==> #t
(color? cp) ==> #t
(get-x cp) ==> 1
(hue cp) ==> green
(info cp) ==> <undefined>
<field label>s have to belong to the record type <type name>.
If this condition is not satisfied, an expansion time error must be signaled.
<expression> -> (<type name> (<field label> <expression>) ...)
(color-point (info 'hi) (x 1) (y 2))
==> (color-point (hue <undefined>) (x 1) (y 2) (info hi))
<expression> -> (record-update <record> <type name> (<field label> <expression>) ...)
-> (record-update* <record> <type name> (<field label> <expression>) ...)
-> (record-update! <record> <type name> (<field label> <expression>) ...)
The first alternative is used for polymorphic functional record update. The expression
<record> must evaluate to a record value that belongs to a subtype of
<type name>. The result will be a new record value of the same type as
the original <record>, with the given fields updated. The original
record value is unaffected. All the
<field label>s have to belong to the record type <type name>.
If this condition is not satisfied, an expansion time error must be signaled.
The second alternative is used for monomorphic functional record update. The expression
<record> must evaluate to a record value that belongs to a subtype of
<type name>. The result will be a new record value of type
<type name>, with the given fields updated. The original
record value is unaffected. All the
<field label>s have to belong to the record type <type name>.
If this condition is not satisfied, an expansion time error must be signaled.
The third alternative is used for in-place record update. The expression
<record> must evaluate to a record value that belongs to a subtype of
<type name>. The result will be the original record value
<type name>, with the given fields, which must be mutable,
updated in place.
Note that a useful value is returned. All the
<field label>s have to belong to the record type <type name>
and, in addition, be mutable.
If this condition is not satisfied, an expansion time error must be signaled.
Apart from this, a mechanism for functional update facilitates and encourages functional-style programming with records. It is particularly useful when we are updating only a few fields of a large record.
A rationale for the naming convention is as follows: the shortest name is
given to the more general polymorphic update form, which is the safest in that it
can be used in most
instances where the monomorphic update* would suffice, and the
former can indeed be replaced by the latter for efficiency when the programmer knows
that the situation requires only monomorphic update. A destructive linear version
update! is provided especially for cases where the programmer
knows that no other references to a value exist, to produce what is, observationally, a
pure-functional result. In these cases, an update or
update* operation may be replaced by update! for efficiency.
See SRFI-1 for a good discussion of linear update procedures.
(define-record-type point2 #f #f (x) (y)) (define-record-type (point3 point2) #f #f (x) (y) (z)) (define p (point3 (x 1) (y 1) (z 3))) (record-update p point2 (y 5)) ==> (point3 (x 1) (y 5) (z 3)) -- polymorphic update p ==> (point3 (x 1) (y 1) (z 3)) -- original unaffected (record-update* p point2 (y 5)) ==> (point2 (x 1) (y 5)) -- monomorphic update p ==> (point3 (x 1) (y 1) (z 3)) -- original unaffected (record-update! p point2 (y 5)) ==> (point3 (x 1) (y 5) (z 3)) -- destructive update p ==> (point3 (x 1) (y 5) (z 3)) -- original updated
<expression> -> (record-compose ((<import-type name> <record>) ...)
(<export-type name> (<field label> <expression>) ...)
Here each expression <record> must evaluate to a record value belonging to
a subtype of
<import-type name>. The expression
evaluates to a record value of type <export-type name> whose fields are
populated as follows: All fields of the imported record values that also belong to the type
<export type name> by comparing labels are imported from left to
right, dropping any repeated fields. The additional fields <field label>
are then populated with the corresponding <expression>, overwriting
any fields with the same labels already imported.
All the
<field label>s have to belong to the record type <export type name>.
If this condition is not satisfied, an expansion time error must be signaled.
The exported record type
<export-type name> does not have to be a subtype of all the import types.
(define c (color (hue 'green)))
(define p (point (x 1) (y 2)))
(record-compose ((point p)
(color c))
(color-point (x 5)
(info 'hi))) ==> (color-point (hue green) (x 5) (y 2) (info hi))
; Another record composition example:
(define-record-type monoid #f #f
(mult monoid.mult)
(one monoid.one))
(define-record-type abelian-group #f #f
(add group.add)
(zero group.zero)
(sub group.sub))
(define-record-type ring #f #f
(mult ring.mult)
(one ring.one)
(add ring.add)
(zero ring.zero)
(sub ring.sub))
; A simple functor
(define (make-ring g m)
(record-compose ((monoid m)
(abelian-group g))
(ring)))
(define integer-monoid (monoid (mult *)
(one 1)))
(define integer-group (abelian-group (add +)
(zero 0)
(sub -)))
(define integer-ring (make-ring integer-group
integer-monoid))
((ring.add integer-ring) 1
2) ;==> 3
The reference implementations use the macro mechanism of R5RS. They do not use any other SRFI or any library.
Two reference implementations are given. One represents records as closures, while the other represents records as vectors. Depending on the application, the implementation based on closures may in fact perform better.
This version depends on define being treated as a binding form by syntax-rules.
This is true for recent versions of portable syntax-case, for PLT, for Scheme48, and possibly others.
The SRFI specification was designed with the constraint that all record expressions containing field labels be translatable into positional expressions at macro-expansion time. For example, labeled record expressions and patterns should be just as efficient as positional constructors and patterns. This is true for the reference implementation.
In a deviation from the specification, record types defined by the reference implementation are not generative, and not disjoint from other types. Since various Schemes have their own ways of defining unique tags or types, it is left to implementors to choose the best way of achieving generativity. A simple mechanism for achieving generativity is implemented in SRFI-9. However, since this mechanism is not foolproof and slows down certain key primitives, it was not adopted here.
Only the names in the exports section should be visible to the user. The other name should be hidden by a suitable module system or naming convention.
Stub implementations are given for pattern matching, hopefully to be specified in a future SRFI. This is done because in the absence of static analysis, providing pattern matching as a primitive is much more efficient for certain common programming patterns. For example, writing
(match r
((r1 : f1 ... fn) (.... (f1 r) ....
.... (f2 r) ....
...
.... (fn r) ....)))
for the common pattern
(cond
((r1? r) (.... (r1.field1 r) ....
.... (r1.field2 r) ....
...
.... (r1.fieldn r) ....)))
will save at least n type tests, and up to kn type tests in the
presence of subtyping with depth k.
The last section contains a few examples and (non-exhaustive) tests.
;==============================================================================
; Andre van Tonder, 2004.
; Records are implemented as vectors, with the attending virtual tables
; for polymorphism included in a dispatcher procedure.
;==============================================================================
; Exports:
(define-syntax define-record-type
(syntax-rules ()
((define-record-type (name super ...) constructor-clause name? field ...)
(build-record name (super ...) constructor-clause name? (field ...)))
((define-record-type (name super ...) constructor-clause)
(define-record-type (name super ...) constructor-clause #f))
((define-record-type (name super ...))
(define-record-type (name super ...) #f #f))
((define-record-type name . rest)
(define-record-type (name) . rest))))
(define-syntax record-update
(syntax-rules ()
((record-update record name (label exp) ...)
(update name record ((label exp) ...)))))
(define-syntax record-update*
(syntax-rules ()
((record-update* record name (label exp) ...)
(record.labels name
(update* name record ((label exp) ...))))))
(define-syntax record-update!
(syntax-rules ()
((record-update! record name (label exp) ...)
(update! name record ((label exp) ...)))))
(define-syntax record-compose
(syntax-rules ()
((record-compose () (export-name (label exp) ...))
(export-name (label exp) ...))
((record-compose ((name val) . imports) (export-name (label exp) ...))
(syntax-map (name export-name) (record.labels)
(compose 1 ((name val) . imports) (export-name (label exp) ...))))))
;==================================================================================
; Internal record utilities:
(define <record> '<record>)
(define <undefined> '<undefined>)
(define-syntax build-record
(syntax-rules ()
((build-record name supers (make-name pos-label ...) name? fields)
(build-record name supers (make-name pos-label ...) (pos-label ...) name? fields))
((build-record name supers make-name name? fields)
(build-record name supers make-name () name? fields))
((build-record name supers constructor (pos-label ...) name? fields)
(get-immutable () fields ; -> (immutables . stack) where stack = ()
(get-mutable fields ; -> (mutables immutables . stack)
(get-interfaces supers ; -> (interfaces mutables immutables . stack)
(union-mutables ; -> (mut-labels interfaces mutables immutables . stack)
(extract-labels fields (pos-label ...) name ; -> (labels mut-labels interfaces mutables immutables . stack)
(union-labels ; -> (labels interfaces mut-labels mutables immutables . stack)
(recolor-identifiers
(emit-record 1 name constructor name?)))))))))))
(define-syntax emit-record
(syntax-rules ()
((emit-record (labels interfaces . stack) 1 name (make-name . pos-labels) name?)
(syntax-map (labels pos-labels interfaces) (add-temporaries)
(emit-record 2 labels name make-name name? . stack)))
((emit-record (labels . stack) 1 name make-name name?)
(emit-record (labels . stack) 1 name (make-name . labels) name?))
((emit-record (((label index) ...) ((pos-label pos-temp) ...) (((super super-label ...) vtable) ...)) 2
labels name make-name name? (mut-label ...)
((label** get-label** set-label!**) ...)
((label* get-label*) ...))
(begin
(define n 3)
(begin
(define index n)
(set! n (+ n 1)))
...
(define-syntax name
(syntax-rules (label ...)
((name ("index") label) index)
...))
(define maker
(let ((dispatcher
(let ((vtable (vector #f #f #f (record.index name super-label) ...))
...)
(lambda (interface sk fk)
(case interface
((name) (sk (lambda (n) n)))
((super) (sk (lambda (n) (vector-ref vtable n))))
...
(else (fk))))))
(printer
(lambda (record)
(list 'name
(list 'label
(vector-ref record
(record.index name label)))
...))))
(lambda labels
(make-record dispatcher
printer
label
...))))
(define (constructor pos-temp ...)
(populate maker 1 labels (pos-label pos-temp) ...))
(define-if make-name constructor)
(define-if name?
(lambda (val)
(and (record? val)
((record.dispatcher val) 'name
(lambda ignore #t)
(lambda () #f)))))
(define-if get-label*
(lambda (record)
((record.dispatcher record) 'name
(lambda (idx)
(vector-ref record
(idx (record.index name label*))))
(lambda () (error "Invalid argument" (show record)
"for" 'get-label*)))))
...
(define-if get-label**
(lambda (record)
((record.dispatcher record) 'name
(lambda (idx)
(vector-ref record
(idx (record.index name label**))))
(lambda () (error "Invalid argument" (show record)
"for" 'get-label**)))))
...
(define-if set-label!**
(lambda (record val)
((record.dispatcher record) 'name
(lambda (idx)
(vector-set! record
(idx (record.index name label**))
val)
record)
(lambda () (error "Invalid argument" (show record)
"for" 'set-label**)))))
...
(define-syntax name
(syntax-rules (: name label ... super ...)
((name ("labels") k) (syntax-apply k labels))
((name ("mutables") k) (syntax-apply k (mut-label ...)))
((name ("interfaces") k) (syntax-apply k ((super super-label ...) ... (name label ...))))
((name ("match") val (: . pats) sk fk) (syntax-zip (pos-label ...) pats
(match-labels name labels val sk fk)
(syntax-error "Wrong number of patterns in match"
(name : pats)
"Positional fields are"
(pos-label ...))))
((name ("match") val bindings sk fk) (match-labels bindings name labels val sk fk))
((name ("mutable?") mut-label sk fk) sk)
...
((name ("mutable?") other sk fk) fk)
((name ("index") label) index)
...
((name . bindings) (populate maker 1 labels . bindings))))
(newline)
(display "Record: ") (display 'name) (newline)
(display "Labels: ") (display 'labels) (newline)
(display "Constr: ") (display '(pos-label ...)) (newline)
(display "Supers: ")
(for-each (lambda (int) (display int) (newline)
(display " "))
(reverse '((super super-label ...) ...)))
(newline)))))
(define-syntax make-record
(syntax-rules ()
((make-record dispatcher printer field ...)
(vector <record> dispatcher printer field ...))))
(define (record? x)
(and (vector? x)
(> (vector-length x) 2)
(eq? (vector-ref x 0) <record>)))
(define (record.dispatcher r) (vector-ref r 1))
(define (record.printer r) (vector-ref r 2))
(define-syntax record.labels
(syntax-rules ()
((record.labels name k)
(name ("labels") k))))
(define-syntax record.mutables
(syntax-rules ()
((record.mutables name k)
(name ("mutables") k))))
(define-syntax record.if-mutable?
(syntax-rules ()
((record.if-mutable? label name sk fk)
(name ("mutable?") label sk fk))))
(define-syntax record.interfaces
(syntax-rules ()
((record.interfaces name k)
(name ("interfaces") k))))
(define-syntax record.index
(syntax-rules ()
((record.index name label)
(name ("index") label))))
(define (record-copy record)
(let* ((ln (vector-length record))
(new (make-vector ln)))
(let recur ((i 0))
(if (= i ln)
new
(begin (vector-set! new i (vector-ref record i))
(recur (+ i 1)))))))
(define-syntax define-if
(syntax-rules ()
((define-if #f binding) (begin))
((define-if name binding) (define name binding))))
(define (record->list r)
((record.printer r) r))
(define (show x)
(if (record? x)
(record->list x)
x))
(define-syntax extract-labels
(syntax-rules ()
((extract-labels stack fields pos-labels name k)
(syntax-map fields (syntax-car)
(syntax-append-after pos-labels
(remove-duplicates top:if-free=
(push-result stack k)))))))
(define-syntax get-immutable
(syntax-rules ()
((get-immutable stack fields k)
(syntax-filter fields (if-immutable?)
(push-result stack k)))))
(define-syntax if-immutable?
(syntax-rules ()
((if-immutable? (a b) sk fk) sk)
((if-immutable? other sk fk) fk)))
(define-syntax get-mutable
(syntax-rules ()
((get-mutable stack fields k)
(syntax-filter fields (if-mutable?)
(push-result stack k)))))
(define-syntax if-mutable?
(syntax-rules ()
((if-mutable? (a b c) sk fk) sk)
((if-mutable? other sk fk) fk)))
(define-syntax get-interfaces
(syntax-rules ()
((get-interfaces stack supers k)
(syntax-map supers (record.interfaces)
(syntax-append-all
(remove-duplicates interface=
(push-result stack k)))))))
(define-syntax interface=
(syntax-rules ()
((interface= (name . stuff) (name* . stuff*) sk fk)
(top:if-free= name name* sk fk))))
(define-syntax union-mutables
(syntax-rules ()
((union-mutables (interfaces ((mutable . stuff) ...) . stack) k)
(syntax-map interfaces (syntax-car)
(syntax-map (record.mutables)
(syntax-cons-after (mutable ...)
(syntax-append-all
(remove-duplicates top:if-free=
(push-result (interfaces ((mutable . stuff) ...) . stack) k)))))))))
(define-syntax union-labels
(syntax-rules ()
((union-labels (labels mut-labels interfaces . stack) k)
(syntax-map interfaces (syntax-cdr)
(syntax-append (labels)
(syntax-append-all
(remove-duplicates top:if-free=
(push-result (interfaces mut-labels . stack) k))))))))
(define-syntax recolor-identifiers
(syntax-rules ()
((recolor-identifiers (labels . rest) k)
(recolor top:if-free= labels rest
(syntax-cons-after labels k)))))
(define-syntax populate
(syntax-rules ()
((populate maker 1 labels (label exp) ...)
(order labels ((label . exp) ...) <undefined>
(populate 2 maker)))
((populate ((label . exp) ...) 2 maker)
(maker exp ...))))
(define-syntax order
(syntax-rules ()
((order ordering alist default k)
(order ordering alist alist () default k))
((order () () () accum default k)
(syntax-apply k accum))
((order (label* . labels*) bindings () (binding* ...) default k)
(order labels* bindings bindings (binding* ... (label* . default)) default k))
((order () ((label . value) . rest) countdown bindings* default k)
(syntax-error "Illegal label in" (label value)
"Legal bindings are" bindings*))
((order (label* . labels*)
((label . value) binding ...)
(countdown . countdowns)
(binding* ...)
default
k)
(if-free= label label*
(order labels*
(binding ...)
(binding ...)
(binding* ... (label . value))
default
k)
(order (label* . labels*)
(binding ... (label . value))
countdowns
(binding* ...)
default
k)))))
(define-syntax update
(syntax-rules ()
((update name record ((label exp) ...))
(let* ((val record)
(new (record-copy val)))
((record.dispatcher val) 'name
(lambda (idx)
(vector-set! new
(idx (record.index name label))
exp)
...
new)
(lambda () (error "Value" (show val)
"is not of record type" 'name)))))))
(define-syntax update!
(syntax-rules ()
((update! name record ((label exp) ...))
(syntax-andmap (label ...) (record.if-mutable? name)
(let ((val record))
((record.dispatcher val) 'name
(lambda (idx) (vector-set! val
(idx (record.index name label))
exp)
...
val)
(lambda () (error "Value" (show val)
"is not of record type" 'name))))
(syntax-error "Attempt to update! immutable field:"
(update! name record ((label exp) ...)))))))
(define-syntax update*
(syntax-rules ()
((update* (label ...) name record ((label* exp) ...))
(let ((val record))
((record.dispatcher val) 'name
(lambda (idx)
(let ((new (name (label (vector-ref val
(idx (record.index name label))))
...)))
(vector-set! new
(idx (record.index name label*))
exp)
...
new))
(lambda () (error "Value" (show val)
"is not of record type" 'name)))))))
(define-syntax compose
(syntax-rules ()
((compose (labels export-labels) 1 ((name record) . imports) (export-name . bindings))
(syntax-filter labels (if-member? export-labels if-free=)
(syntax-filter (if-not-member? bindings)
(compose 2 ((name record) . imports) (export-name . bindings)))))
((compose (label ...) 2 ((name record) . imports) (export-name . bindings))
(let ((val record))
((record.dispatcher val) 'name
(lambda (idx)
(record-compose imports
(export-name (label (vector-ref val
(idx (record.index name label))))
...
. bindings)))
(lambda () (error "Value" (show val)
"is not of record type" 'name)))))))
(define-syntax if-not-member?
(syntax-rules ()
((if-not-member? label () sk fk) sk)
((if-not-member? label ((label* . stuff*) . bindings) sk fk)
(if-free= label label*
fk
(if-not-member? label bindings sk fk)))))
(define-syntax record-match
(syntax-rules (_)
((record-match exp)
(error "Match failure for" exp))
((record-match (f . args) clause ...)
(let ((val (f . args)))
(record-match val clause ...)))
((record-match val ((name . pattern) . template) clause ...)
(name ("match") val pattern
(begin . template)
(record-match val clause ...)))
((record-match val (_ . template) clause ...)
(begin . template))
((record-match val (x . template) clause ...)
(let ((x val)) . template))))
(define-syntax match-labels
(syntax-rules ()
((match-labels ((label pat) ...) name labels val sk fk)
(syntax-andmap (label ...) (if-member? labels if-free=)
(let ((fail (lambda () fk)))
(if (record? val)
((record.dispatcher val) 'name
(lambda (idx)
(match-each ((pat (vector-ref val
(idx (record.index name label))))
...)
sk
fail))
fail)
(fail)))
(syntax-error "Attempt to match illegal label in match expression"
(name (label pat) ...)
"Legal labels are" labels)))))
(define-syntax match-each
(syntax-rules ()
((match-each () sk fail)
sk)
((match-each ((pat var) . bindings) sk fail)
(record-match var
(pat (match-each bindings sk fail))
(_ (fail))))))
;====================================================================
; Internal syntax utilities:
(define-syntax syntax-error (syntax-rules ()))
(define-syntax syntax-apply
(syntax-rules ()
((syntax-apply (f . args) exp ...)
(f exp ... . args))))
(define-syntax if-free=
(syntax-rules ()
((if-free= x y kt kf)
(let-syntax
((test (syntax-rules (x)
((test x kt* kf*) kt*)
((test z kt* kf*) kf*))))
(test y kt kf)))))
(define-syntax top:if-free=
(syntax-rules ()
((top:if-free= x y kt kf)
(begin
(define-syntax if-free=:test
(syntax-rules (x)
((if-free=:test x kt* kf*) kt*)
((if-free=:test z kt* kf*) kf*)))
(if-free=:test y kt kf)))))
(define-syntax syntax-cons
(syntax-rules ()
((syntax-cons x rest k) (syntax-apply k (x . rest)))))
(define-syntax syntax-cons-after
(syntax-rules ()
((syntax-cons-after rest x k) (syntax-apply k (x . rest)))))
(define-syntax syntax-car
(syntax-rules ()
((syntax-car (h . t) k) (syntax-apply k h))))
(define-syntax syntax-cdr
(syntax-rules ()
((syntax-cdr (h . t) k) (syntax-apply k t))))
(define-syntax syntax-foldr
(syntax-rules ()
((syntax-foldr accum (f arg ...) () k)
(syntax-apply k accum))
((syntax-foldr accum (f arg ...) (h . t) k)
(syntax-foldr accum (f arg ...) t
(f h arg ... k)))))
(define-syntax syntax-append
(syntax-rules ()
((syntax-append (a ...) (b ...) k) (syntax-apply k (a ... b ...)))))
(define-syntax syntax-append-all
(syntax-rules ()
((syntax-append-all lists k)
(syntax-foldr () (syntax-append-after) lists k))))
(define-syntax syntax-append-after
(syntax-rules ()
((syntax-append-after y x k) (syntax-append x y k))))
(define-syntax syntax-filter
(syntax-rules ()
((syntax-filter () (if-p? arg ...) k)
(syntax-apply k ()))
((syntax-filter (h . t) (if-p? arg ...) k)
(if-p? h arg ...
(syntax-filter t (if-p? arg ...) (syntax-cons-after h k))
(syntax-filter t (if-p? arg ...) k)))))
(define-syntax syntax-map
(syntax-rules ()
((syntax-map () (f arg ...) k) (syntax-apply k ()))
((syntax-map (h . t) (f arg ...) k) (syntax-map t (f arg ...)
(syntax-map (f arg ...) h k)))
((syntax-map done (f arg ...) h k) (f h arg ...
(syntax-cons done k)))))
(define-syntax syntax-andmap
(syntax-rules ()
((syntax-andmap () (if-p? arg ...) sk fk) sk)
((syntax-andmap (h . t) (if-p? arg ...) sk fk)
(if-p? h arg ...
(syntax-andmap t (if-p? arg ...) sk fk)
fk))))
(define-syntax add-temporaries
(syntax-rules ()
((add-temporaries lst k) (add-temporaries lst () k))
((add-temporaries () lst-temps k) (syntax-apply k lst-temps))
((add-temporaries (h . t) (done ...) k) (add-temporaries t (done ... (h temp)) k))))
(define-syntax syntax-zip
(syntax-rules ()
((syntax-zip () () sk fk) (syntax-apply sk ()))
((syntax-zip () lst* sk fk) fk)
((syntax-zip lst () sk fk) fk)
((syntax-zip (h . t) (h* . t*) sk fk) (syntax-zip t t*
(syntax-cons-after (h h*) sk)
fk))))
(define-syntax push-result
(syntax-rules ()
((push-result x stack k) (syntax-apply k (x . stack)))))
(define-syntax remove-duplicates
(syntax-rules ()
((remove-duplicates lst compare? k)
(remove-duplicates lst () compare? k))
((remove-duplicates () done compare? k)
(syntax-apply k done))
((remove-duplicates (h . t) (d ...) compare? k)
(if-member? h (d ...) compare?
(remove-duplicates t (d ...) compare? k)
(remove-duplicates t (d ... h) compare? k)))))
(define-syntax if-member?
(syntax-rules ()
((if-member? x () compare? sk fk)
fk)
((if-member? x (h . t) compare? sk fk)
(compare? x h
sk
(if-member? x t compare? sk fk)))))
(define-syntax recolor
(syntax-rules ()
((recolor compare labels () k)
(syntax-apply k ()))
((recolor compare labels (h . t) k)
(recolor compare labels h
(recolor compare labels t "combine" k)))
((recolor h-done compare labels to-do "combine" k)
(recolor compare labels to-do
(syntax-cons-after h-done k)))
((recolor compare labels id k)
(get-equiv compare id labels k))))
(define-syntax get-equiv
(syntax-rules ()
((get-equiv compare label () k)
(syntax-apply k label))
((get-equiv compare label (h . t) k)
(compare h label
(syntax-apply k h)
(get-equiv compare label t k)))))
;=============================================================================
; End of reference implementation
;=============================================================================
;==============================================================================
; Andre van Tonder, 2004.
; Records are implemented as closures that inject their fields into
; a continuation.
;==============================================================================
; Exports:
(define-syntax define-record-type
(syntax-rules ()
((define-record-type (name super ...) constructor-clause name? field ...)
(build-record name (super ...) constructor-clause name? (field ...)))
((define-record-type (name super ...) constructor-clause)
(define-record-type (name super ...) constructor-clause #f))
((define-record-type (name super ...))
(define-record-type (name super ...) #f #f))
((define-record-type name . rest)
(define-record-type (name) . rest))))
(define-syntax record-update
(syntax-rules ()
((record-update record name (label exp) ...)
(record.labels name
(update 1 name record ((label exp) ...))))))
(define-syntax record-update*
(syntax-rules ()
((record-update* record name (label exp) ...)
(record.labels name
(update* 1 name record ((label exp) ...))))))
(define-syntax record-update!
(syntax-rules ()
((record-update! record name (label exp) ...)
(record.labels name
(update! 1 name record ((label exp) ...))))))
(define-syntax record-compose
(syntax-rules ()
((record-compose () (export-name (label exp) ...))
(export-name (label exp) ...))
((record-compose ((name val) . imports) (export-name (label exp) ...))
(syntax-map (name export-name) (record.labels)
(compose 1 (export-name (label exp) ...) name val imports)))))
;==================================================================================
; Internal record utilities:
(define <record> '<record>)
(define <undefined> '<undefined>)
(define-syntax build-record
(syntax-rules ()
((build-record name supers (make-name pos-label ...) name? fields)
(build-record name supers (make-name pos-label ...) (pos-label ...) name? fields))
((build-record name supers make-name name? fields)
(build-record name supers make-name () name? fields))
((build-record name supers constructor (pos-label ...) name? fields)
(get-immutables () fields ; -> (immutables . stack) where stack = ()
(get-mutables fields ; -> (mutables immutables . stack)
(get-interfaces supers ; -> (interfaces mutables immutables . stack)
(union-mutables ; -> (mut-labels interfaces mutables immutables . stack)
(extract-labels fields (pos-label ...) name ; -> (labels mut-labels interfaces mutables immutables . stack)
(union-labels ; -> (labels mut-labels interfaces mutables immutables . stack)
(recolor-identifiers
(emit-record 1 name constructor name?)))))))))))
(define-syntax emit-record
(syntax-rules ()
((emit-record (labels . stack) 1 name (make-name pos-label ...) name?)
(add-temporaries (pos-label ...)
(emit-record 2 labels labels name make-name name? stack)))
((emit-record (labels . stack) 1 name make-name name?)
(emit-record (labels . stack) 1 name (make-name . labels) name?))
((emit-record ((pos-label pos-temp) ...) 2 (label ...) labels
name make-name name? ((mut-label ...)
((super super-label ...) ...)
((label** get-label** set-label!**) ...)
((label* get-label*) ...) . stack))
(begin
(define maker
(let ()
(define (printer record)
((cadr record) 'name
(lambda labels
(let ((mut-label (unbox mut-label))
...)
(list 'name (list 'label label) ...)))
(lambda () (error))))
(define (updater record)
((cadr record) 'name
(lambda labels
(lambda (super-tag fields-k)
(let ((mut-label (unbox mut-label))
...)
(fields-k
(case super-tag
((name) (lambda labels
(maker . labels)))
((super) (lambda (super-label ...)
(maker . labels)))
...)))))
(lambda () (error))))
(lambda labels
(let ((mut-label (make-box mut-label))
...)
(list <record>
(lambda (interface sk fk)
(case interface
((name) (sk label ...))
((super) (sk super-label ...))
...
(else (fk))))
updater
printer)))))
(define (constructor pos-temp ...)
(make-record maker labels (pos-label pos-temp) ...))
(define-if make-name constructor)
(define-if name?
(lambda (val)
(and (record? val)
((cadr val) 'name
(lambda ignore #t)
(lambda () #f)))))
(define-if get-label**
(lambda (record)
((cadr record) 'name
(lambda labels
(unbox label**))
(lambda () (error "Invalid argument" (show record)
"for" 'get-label**)))))
...
(define-if get-label*
(lambda (record)
((cadr record) 'name
(lambda labels label*)
(lambda () (error "Invalid argument" (show record)
"for" 'get-label*)))))
...
(define-if set-label!**
(lambda (record val)
((cadr record) 'name
(lambda labels
(begin (set-box! label** val)
record))
(lambda () (error "Invalid argument" (show record)
"for" 'set-label!**)))))
...
(define-syntax name
(syntax-rules (: name label ... super ...)
((name ("labels") k) (syntax-apply k labels))
((name ("positionals") k) (syntax-apply k (pos-label ...)))
((name ("mutables") k) (syntax-apply k (mut-label ...)))
((name ("interfaces") k) (syntax-apply k ((super super-label ...) ... (name label ...))))
((name ("mutable?") mut-label sk fk) sk)
...
((name ("mutable?") other sk fk) fk)
((name ("match") val (: . pats) sk fk) (syntax-zip (pos-label ...) pats
(match-labels 1 labels name val sk fk)
(syntax-error "Wrong number of patterns in match"
(name : pats)
"Positional fields are"
(pos-label ...))))
((name ("match") val bindings sk fk) (match-labels bindings 1 labels name val sk fk))
((name . bindings) (make-record maker labels . bindings))))
(newline)
(display "Record: ") (display 'name) (newline)
(display "Labels: ") (display 'labels) (newline)
(display "Constr: ") (display '(pos-label ...)) (newline)
(display "Supers: ")
(for-each (lambda (int) (display int) (newline)
(display " "))
(reverse '((super super-label ...) ...)))
(newline)))))
(define-syntax record.labels
(syntax-rules ()
((record-labels name k) (name ("labels") k))))
(define-syntax record.mutables
(syntax-rules ()
((record.mutables name k) (name ("mutables") k))))
(define-syntax record.interfaces
(syntax-rules ()
((record.interfaces name k) (name ("interfaces") k))))
(define-syntax define-if
(syntax-rules ()
((define-if #f binding) (begin))
((define-if name binding) (define name binding))))
(define (record? x)
(and (pair? x)
(eq? (car x) <record>)))
(define (record->list r)
((cadddr r) r))
(define (show x)
(if (record? x)
(record->list x)
x))
(define-syntax extract-labels
(syntax-rules ()
((extract-labels stack fields pos-labels name k)
(syntax-map fields (syntax-car)
(syntax-append-after pos-labels
(remove-duplicates top:if-free=
(push-result stack k)))))))
(define-syntax get-immutables
(syntax-rules ()
((get-immutables stack fields k)
(syntax-filter fields (if-immutable?)
(push-result stack k)))))
(define-syntax if-immutable?
(syntax-rules ()
((if-immutable? (a b) sk fk) sk)
((if-immutable? other sk fk) fk)))
(define-syntax get-mutables
(syntax-rules ()
((get-mutables stack fields k)
(syntax-filter fields (if-mutable?)
(push-result stack k)))))
(define-syntax if-mutable?
(syntax-rules ()
((if-mutable? (a b c) sk fk) sk)
((if-mutable? other sk fk) fk)))
(define-syntax get-interfaces
(syntax-rules ()
((get-interfaces stack supers k)
(syntax-map supers (record.interfaces)
(syntax-append-all
(remove-duplicates interface=
(push-result stack k)))))))
(define-syntax interface=
(syntax-rules ()
((interface= (name . stuff) (name* . stuff*) sk fk)
(top:if-free= name name* sk fk))))
(define-syntax union-mutables
(syntax-rules ()
((union-mutables (interfaces ((mutable . stuff) ...) . stack) k)
(syntax-map interfaces (syntax-car) ; abstract this
(syntax-map (record.mutables)
(syntax-cons-after (mutable ...)
(syntax-append-all
(remove-duplicates top:if-free=
(push-result (interfaces ((mutable . stuff) ...) . stack) k)))))))))
(define-syntax union-labels
(syntax-rules ()
((union-labels (labels mut-labels interfaces . stack) k)
(syntax-map interfaces (syntax-cdr)
(syntax-append (labels)
(syntax-append-all
(remove-duplicates top:if-free=
(push-result (mut-labels interfaces . stack) k))))))))
(define-syntax recolor-identifiers
(syntax-rules ()
((recolor-identifiers (labels . rest) k)
(recolor top:if-free= labels rest
(syntax-cons-after labels k)))))
(define-syntax make-record
(syntax-rules ()
((make-record maker labels (label exp) ...)
(order labels ((label . exp) ...) <undefined>
(populate maker)))))
(define-syntax populate
(syntax-rules ()
((populate ((label . exp) ...) maker)
(maker exp ...))))
(define-syntax order
(syntax-rules ()
((order ordering alist default k)
(order ordering alist alist () default k))
((order () () () accum default k)
(syntax-apply k accum))
((order (label* . labels*) bindings () (binding* ...) default k)
(order labels* bindings bindings (binding* ... (label* . default)) default k))
((order () ((label . value) . rest) countdown bindings* default k)
(syntax-error "Illegal label in" (label value)
"Legal bindings are" bindings*))
((order (label* . labels*)
((label . value) binding ...)
(countdown . countdowns)
(binding* ...)
default
k)
(if-free= label label*
(order labels*
(binding ...)
(binding ...)
(binding* ... (label . value))
default
k)
(order (label* . labels*)
(binding ... (label . value))
countdowns
(binding* ...)
default
k)))))
(define-syntax update
(syntax-rules ()
((update labels 1 name record bindings)
(order labels bindings (#f)
(syntax-map (insert-pattern)
(update 2 record name))))
((update ((label pat binding) ...) 2 record name)
(let ((val record))
(record-match val
((name (label pat) ...)
(((caddr val) val) 'name
(lambda (k) (k binding ...)))))))))
(define-syntax update*
(syntax-rules ()
((update* labels 1 name record bindings)
(order labels bindings (#f)
(syntax-map (insert-pattern)
(update* 2 name record))))
((update* ((label pat binding) ...) 2 name record)
(record-match record
((name (label pat) ...)
(name (label binding) ...))))))
(define-syntax insert-pattern
(syntax-rules ()
((insert-pattern (label #f) k) (syntax-apply k (label temp temp)))
((insert-pattern (label binding) k) (syntax-apply k (label _ binding)))))
(define-syntax update!
(syntax-rules ()
((update! labels 1 name record ((label binding) ...))
(recolor if-free= labels (label ...)
(update! 2 labels name record (binding ...))))
((update! (label ...) 2 labels name record (binding ...))
(let ((val record))
((cadr val) 'name
(lambda labels
(set-box! label binding)
...
val)
(lambda () (error "Update!" (show val)
"is not of expected type" 'name)))))))
(define-syntax compose
(syntax-rules ()
((compose (labels export-labels) 1 export name exp imports)
(syntax-filter labels (if-member? export-labels if-free=)
(add-temporaries
(compose 2 export name exp imports))))
((compose ((label temp) ...) 2 (export-name . bindings) name exp imports)
(syntax-filter ((label temp) ...) (if-not-member? bindings)
(compose 3 ((label temp) ...) export-name bindings name exp imports)))
((compose ((label* temp*) ...) 3 ((label temp) ...) export-name bindings name exp imports)
(let ((val exp))
(record-match val
((name (label temp) ...)
(record-compose imports (export-name (label* temp*) ... . bindings))))))))
(define-syntax if-not-member?
(syntax-rules ()
((if-not-member? (label . stuff) () sk fk) sk)
((if-not-member? (label . stuff) ((label* . stuff*) . rest) sk fk)
(if-free= label label*
fk
(if-not-member? (label . stuff) rest sk fk)))))
(define-syntax record-match
(syntax-rules (_)
((record-match exp)
(error "Match failure for" exp))
((record-match (f . args) clause ...)
(let ((val (f . args)))
(record-match val clause ...)))
((record-match val ((name . pattern) . template) clause ...)
(name ("match") val pattern
(begin . template)
(record-match val clause ...)))
((record-match val (_ . template) clause ...)
(begin . template))
((record-match val (x . template) clause ...)
(let ((x val)) . template))))
(define-syntax match-labels
(syntax-rules ()
((match-labels bindings 1 labels name val sk fk)
(order labels bindings (_)
(add-temporaries
(match-labels 2 val name sk fk))))
((match-labels (((label pat) var) ...) 2 val name sk fk)
(syntax-filter ((label var) ...) (if-mutable-entry? name)
(match-labels 3 ((label pat var) ...) val name sk fk)))
((match-labels ((mut-label mut-var) ...) 3 ((label pat var) ...) val name sk fk)
(let ((fail (lambda () fk)))
(if (record? val)
((cadr val) 'name
(lambda (var ...)
(let ((mut-var (unbox mut-var))
...)
(match-each ((pat var) ...) sk fail)))
fail)
(fail))))))
(define-syntax match-each
(syntax-rules ()
((match-each () sk fail)
sk)
((match-each ((pat var) . bindings) sk fail)
(record-match var
(pat (match-each bindings sk fail))
(_ (fail))))))
(define-syntax if-mutable-entry?
(syntax-rules ()
((if-mutable-entry? (label . rest) name sk fk)
(name ("mutable?") label sk fk))))
; Boxes for mutable fields
(define (make-box x) (cons x '()))
(define box? pair?)
(define unbox car)
(define (set-box! box value) (set-car! box value))
;====================================================================
; Internal syntax utilities:
(define-syntax syntax-error (syntax-rules ()))
(define-syntax syntax-apply
(syntax-rules ()
((syntax-apply (f . args) exp ...)
(f exp ... . args))))
(define-syntax if-free=
(syntax-rules ()
((if-free= x y kt kf)
(let-syntax
((test (syntax-rules (x)
((test x kt* kf*) kt*)
((test z kt* kf*) kf*))))
(test y kt kf)))))
(define-syntax top:if-free=
(syntax-rules ()
((top:if-free= x y kt kf)
(begin
(define-syntax if-free=:test
(syntax-rules (x)
((if-free=:test x kt* kf*) kt*)
((if-free=:test z kt* kf*) kf*)))
(if-free=:test y kt kf)))))
(define-syntax syntax-cons
(syntax-rules ()
((syntax-cons x rest k) (syntax-apply k (x . rest)))))
(define-syntax syntax-cons-after
(syntax-rules ()
((syntax-cons-after rest x k) (syntax-apply k (x . rest)))))
(define-syntax syntax-car
(syntax-rules ()
((syntax-car (h . t) k) (syntax-apply k h))))
(define-syntax syntax-cdr
(syntax-rules ()
((syntax-cdr (h . t) k) (syntax-apply k t))))
(define-syntax syntax-foldr
(syntax-rules ()
((syntax-foldr accum (f arg ...) () k)
(syntax-apply k accum))
((syntax-foldr accum (f arg ...) (h . t) k)
(syntax-foldr accum (f arg ...) t
(f h arg ... k)))))
(define-syntax syntax-map
(syntax-rules ()
((syntax-map () (f arg ...) k) (syntax-apply k ()))
((syntax-map (h . t) (f arg ...) k) (syntax-map t (f arg ...)
(syntax-map (f arg ...) h k)))
((syntax-map done (f arg ...) h k) (f h arg ...
(syntax-cons done k)))))
(define-syntax syntax-append
(syntax-rules ()
((syntax-append (a ...) (b ...) k) (syntax-apply k (a ... b ...)))))
(define-syntax syntax-append-all
(syntax-rules ()
((syntax-append-all lists k)
(syntax-foldr () (syntax-append-after) lists k))))
(define-syntax syntax-append-after
(syntax-rules ()
((syntax-append-after y x k) (syntax-append x y k))))
(define-syntax syntax-filter
(syntax-rules ()
((syntax-filter () (if-p? arg ...) k)
(syntax-apply k ()))
((syntax-filter (h . t) (if-p? arg ...) k)
(if-p? h arg ...
(syntax-filter t (if-p? arg ...) (syntax-cons-after h k))
(syntax-filter t (if-p? arg ...) k)))))
(define-syntax syntax-zip
(syntax-rules ()
((syntax-zip () () sk fk) (syntax-apply sk ()))
((syntax-zip () lst* sk fk) fk)
((syntax-zip lst () sk fk) fk)
((syntax-zip (h . t) (h* . t*) sk fk) (syntax-zip t t*
(syntax-cons-after (h h*) sk)
fk))))
(define-syntax add-temporaries
(syntax-rules ()
((add-temporaries lst k) (add-temporaries lst () k))
((add-temporaries () lst-temps k) (syntax-apply k lst-temps))
((add-temporaries (h . t) (done ...) k) (add-temporaries t (done ... (h temp)) k))))
(define-syntax push-result
(syntax-rules ()
((push-result x stack k) (syntax-apply k (x . stack)))))
(define-syntax remove-duplicates
(syntax-rules ()
((remove-duplicates lst compare? k)
(remove-duplicates lst () compare? k))
((remove-duplicates () done compare? k)
(syntax-apply k done))
((remove-duplicates (h . t) (d ...) compare? k)
(if-member? h (d ...) compare?
(remove-duplicates t (d ...) compare? k)
(remove-duplicates t (d ... h) compare? k)))))
(define-syntax if-member?
(syntax-rules ()
((if-member? x () compare? sk fk)
fk)
((if-member? x (h . t) compare? sk fk)
(compare? x h
sk
(if-member? x t compare? sk fk)))))
(define-syntax recolor
(syntax-rules ()
((recolor compare labels () k)
(syntax-apply k ()))
((recolor compare labels (h . t) k)
(recolor compare labels h
(recolor compare labels t "combine" k)))
((recolor h-done compare labels to-do "combine" k)
(recolor compare labels to-do
(syntax-cons-after h-done k)))
((recolor compare labels id k)
(get-equiv compare id labels k))))
(define-syntax get-equiv
(syntax-rules ()
((get-equiv compare label () k)
(syntax-apply k label))
((get-equiv compare label (h . t) k)
(compare h label
(syntax-apply k h)
(get-equiv compare label t k)))))
(define-syntax if-symbol?
(syntax-rules ()
((if-symbol? (x . y) sk fk) fk)
((if-symbol? #(x ...)) fk)
((if-symbol? x sk fk)
(let-syntax ((test (syntax-rules ()
((test x sk* fk*) sk*)
((test non-x sk* fk*) fk*))))
(test foo sk fk)))))
;=============================================================================
; End of reference implementation
;=============================================================================
;==============================================================================
; Tests:
;=============================================================================
; A simple record:
(define-record-type point (make-point x y) point?
(x get-x set-x!)
(y get-y set-y!))
(define p (make-point 1 2))
(get-y p) ;==> 2
(show
(set-y! p 3)) ;==> (point (x 1) (y 3))
(point? p) ;==> #t
; Subtyping:
(define-record-type color make-color color? ; default argument order is declaration order
(hue hue set-hue!)) ; notice punning
(define-record-type (color-point color point)
(make-color-point x y hue) ; differs from default ordering and arity
color-point?
(info info)) ; additional field left undefined by constructor
(define cp (make-color-point 1 2 'green))
(color-point? cp) ;==> #t
(point? cp) ;==> #t
(color? cp) ;==> #t
(get-x cp) ;==> 1
(hue cp) ;==> green
(info cp) ;==> <undefined>
; Labeled record expressions:
(show
(color-point (info 'hi) (x 1) (y 2)))
;==> (color-point (hue <undefined>) (x 1) (y 2) (info hi))
; Record update
(define-record-type point2 #f #f (x #f #f) (y #f #f))
(define-record-type (point3 point2) #f #f (x #f #f) (y #f #f) (z #f #f))
(define p (point3 (x 1) (y 1) (z 3)))
(show (record-update p point2 (y 5))) ;==> (point3 (x 1) (y 5) (z 3)) -- polymorphic update
(show p) ;==> (point3 (x 1) (y 1) (z 3)) -- original unaffected
(show (record-update* p point2 (y 5))) ;==> (point2 (x 1) (y 5)) -- monomorphic update
(show p) ;==> (point3 (x 1) (y 1) (z 3)) -- original unaffected
(show (record-update! p point2 (y 5))) ;==> (point3 (x 1) (y 5) (z 3)) -- destructive update
(show p)
; Record composition:
(define c (color (hue 'green)))
(define p (point (x 1) (y 2)))
(show
(record-compose ((point p)
(color c))
(color-point (x 5)
(info 'hi)))) ;==> (color-point (hue green) (x 5) (y 2) (info hi))
; Another record composition example:
(define-record-type monoid #f #f
(mult monoid.mult)
(one monoid.one))
(define-record-type abelian-group #f #f
(add group.add)
(zero group.zero)
(sub group.sub))
(define-record-type ring #f #f
(mult ring.mult)
(one ring.one)
(add ring.add)
(zero ring.zero)
(sub ring.sub))
; A simple functor
(define (make-ring g m)
(record-compose ((monoid m)
(abelian-group g))
(ring)))
(define integer-monoid (monoid (mult *)
(one 1)))
(define integer-group (abelian-group (add +)
(zero 0)
(sub -)))
(define integer-ring (make-ring integer-group
integer-monoid))
((ring.add integer-ring) 1 2) ;==> 3
; A tree record type:
(define-record-type node (make-node lhs rhs) node?
(lhs node.lhs)
(rhs node.rhs))
(define-record-type leaf (make-leaf val) leaf?
(val leaf.val))
(define (tree->list t)
(cond
((leaf? t) (leaf.val t))
((node? t) (cons (tree->list (node.lhs t))
(tree->list (node.rhs t))))))
(define t (make-node (make-node (make-leaf 1)
(make-leaf 2))
(make-leaf 3)))
(tree->list t) ;==> ((1 . 2) . 3)
; Test pattern matching stub:
(record-match (color-point (x 1) (y 2) (hue 'blue))
((point (x a) (y b))
(list a b))) ;==> (1 2)
(define (tree->list t)
(record-match t
((leaf : v) v)
((node : l r) (cons (tree->list l)
(tree->list r)))))
(tree->list t) ;==> ((1 . 2) . 3)
;=======================================================================================
[1] Richard Kelsey, Defining Record Types, SRFI-9: http://srfi.schemers.org/srfi-9/srfi-9.html
[2] See e.g.
Benjamin C. Pierce, Types and Programming Languages, MIT Press 2002, and references therein.
Mitchell Wand, Type inference for record concatenation and multiple inheritance,
Information and Computation, v.93 n.1, p.1-15, July 1991
John Reppy, Jon Riecke, Simple objects for Standard ML,
Proceedings of the ACM SIGPLAN '96 Conference on Programming Language Design and Implementation
This document and translations of it may be copied and furnished to others, and derivative works that comment on or otherwise explain it or assist in its implementation may be prepared, copied, published and distributed, in whole or in part, without restriction of any kind, provided that the above copyright notice and this paragraph are included on all such copies and derivative works. However, this document itself may not be modified in any way, such as by removing the copyright notice or references to the Scheme Request For Implementation process or editors, except as needed for the purpose of developing SRFIs in which case the procedures for copyrights defined in the SRFI process must be followed, or as required to translate it into languages other than English.
The limited permissions granted above are perpetual and will not be revoked by the authors or their successors or assigns.
This document and the information contained herein is provided on an "AS IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.