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>)
-> (<field label>)
-> <field label>
<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 ordered set of field labels 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>, at
each step 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.
The syntax (<field label>) is short for
a mutable field declaration (<field label> #f #f).
The syntax <field label> is short for an
immutable field declaration
(<field label> #f).
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 node make-node #f
(left)
(right))
Here (left) is short for (left #f #f), indicating a mutable field.
(define-record-type node (make-node left right) #f
extra)
Here left and right are immutable fields. The field clause
extra is short for (extra #f), indicating an immutable field.
(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) ; 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>
<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 <type name> <record> (<field label> <expression>) ...)
-> (record-update. <type name> <record> (<field label> <expression>) ...)
-> (record-update! <type name> <record> (<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. It is an error to attempt to record-update! immutable fields.
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.
A rationale for the naming convention is as follows:
the more general polymorphic update form 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 expecially for cases where the programmer
knows that no other references to a value exist to produce what is, observationally, a
pure-functional result. 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 point2 p (y 5)) ==> (point3 (x 1) (y 5) (z 3)) -- polymorphic update p ==> (point3 (x 1) (y 1) (z 3)) -- original unaffected (record-update. point2 p (y 5)) ==> (point2 (x 1) (y 5)) -- monomorphic update p ==> (point3 (x 1) (y 1) (z 3)) -- original unaffected (record-update! point2 p (y 5)) ==> (point3 (x 1) (y 5) (z 3)) -- destructive update p ==> (point3 (x 1) (y 5) (z 3)) -- original updated
<expression> -> (record-extend ((<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 exported record type
<export-type name> must be a subtype of all the import types, a condition
that must be checked at compile-time. 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 are imported from left to
right, dropping repeated fields. The additional fields <field label>
are then populated with the corresponding <expression>.
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.
(define c (color (hue 'green)))
(define p (point (x 1) (y 2)))
(record-extend ((point p)
(color c))
(color-point (x 5)
(info 'hi))) ==> (color-point (hue green) (x 5) (y 2) (info hi))
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.
A less efficient version exists that does not make this assumption. Let me know if you
need it and I will post it also.
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/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.
The last section contains a few examples and (non-exhaustive) tests.
;==============================================================================
; IMPLEMENTATION:
;
; Andre van Tonder 2004.
;
; Records are implemented as closures that inject their fields into
; a continuation. Constructors, updaters and extenders by labels are
; compiled into positional expressions at expansion time.
; Mutable fields are represented by boxed values.
;==============================================================================
; 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 name record (label binding) ...)
(name ("labels")
(update-help record (name (label binding) ...))))))
(define-syntax record-update.
(syntax-rules ()
((record-update. name val (label exp) ...)
(name ("labels")
(update.-help name val ((label . exp) ...))))))
(define-syntax record-update!
(syntax-rules ()
((record-update! name val (label exp) ...)
(add-temporaries ((label exp) ...)
(update!-help val name)))))
(define-syntax extend
(syntax-rules ()
((extend () (export-name (label exp) ...))
(export-name (label exp) ...))
((extend ((name val) . imports) export)
(name ("labels")
(extend-help (export name val imports))))))
;====================================================================
; 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 if-symbol?
(syntax-rules ()
((if-symbol? (x . y) sk fk) fk)
((if-symbol? #(x ...) sk fk) 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)))))
(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-foldl
(syntax-rules ()
((syntax-foldl accum (f arg ...) () k)
(syntax-apply k accum))
((syntax-foldl accum (f arg ...) (h . t) k)
(f accum h arg ...
(syntax-foldl (f arg ...) t k)))))
(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 () y k) (syntax-apply k y))
((syntax-append (h . t) y k) (syntax-append t y
(syntax-cons-after h 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-reverse
(syntax-rules ()
((syntax-reverse lst k) (syntax-reverse lst () k))
((syntax-reverse () acc k) (syntax-apply k acc))
((syntax-reverse (h . t) acc k) (syntax-reverse t (h . acc) k))))
(define-syntax syntax-zip
(syntax-rules ()
((syntax-zip lst lst* sk fk) (syntax-zip () lst lst* sk fk))
((syntax-zip accum () () sk fk) (syntax-reverse accum sk))
((syntax-zip accum () lst* sk fk) fk)
((syntax-zip accum lst () sk fk) fk)
((syntax-zip accum (h . t) (h* . t*) sk fk) (syntax-zip ((h . h*) . accum) t t* sk fk))))
(define-syntax add-temporaries
(syntax-rules ()
((add-temporaries lst k) (add-temporaries lst () k))
((add-temporaries () temps k) (syntax-reverse temps k))
((add-temporaries (h . t) temps k) (add-temporaries t ((h temp) . temps) k))))
(define-syntax push-result
(syntax-rules ()
((push-result x stack k) (syntax-apply k (x . stack)))))
;=========================================================================
; Pattern matching interface - used internally:
(define-syntax match
(syntax-rules ()
((match exp . rest)
(if-symbol? exp
(match-var exp . rest)
(let ((var exp))
(match-var var . rest))))))
(define-syntax match-let
(syntax-rules ()
((match-let bindings . body)
(add-temporaries bindings
(match-let-emit body)))))
(define-syntax match-let*
(syntax-rules ()
((match-let* () . body)
(begin . body))
((match-let* (binding . bindings) . body)
(match-let (binding)
(match-let* bindings . body)))))
(define-syntax define-view
(syntax-rules (match)
((define-view name (lit ...)
(match var sk fk
((name* . pat) template)
...)
. rest)
(define-syntax name
(syntax-rules (lit ...)
((name ("match") var pat sk fk) template)
...
. rest)))))
;=============================================================================
; Internal pattern matching utilities:
(define-syntax match-var
(syntax-rules (_ => quote)
((match-var var)
(error "No match for" (show var)))
((match-var var (pattern (=> fail) . body) . rest)
(let ((fail (lambda ()
(match-var var . rest))))
(match-var var (pattern . body) . rest)))
((match-var var (_ . body) . rest)
(begin . body))
((match-var var ((quote x) . body) . rest)
(if (equal? (quote x) var)
(begin . body)
(match-var var . rest)))
((match-var var ((name . pattern) . body) . rest)
(name ("match") var pattern (begin . body) (match-var var . rest)))
((match-var var (x . body) . rest)
(if-symbol? x
(let ((x var)) . body)
(if (eqv? x var)
(begin . body)
(match-var var . rest))))))
(define-syntax match-let-emit
(syntax-rules ()
((match-let-emit (((pat exp) temp) ...) body)
(let ((temp exp) ...)
(match-let-vars ((pat temp) ...) . body)))))
(define-syntax match-let-vars
(syntax-rules ()
((match-let-vars () . body)
(begin . body))
((match-let-vars ((pat var) . bindings) . body)
(match-var var
(pat (match-let-vars bindings . body))
(_ (error "Match-let pattern" 'pat
"does not match value" (show var)))))))
;==================================================================================
; 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)
(begin
(define-syntax name ; used by if-not-in-constructor? below
(syntax-rules (pos-label ...)
((name ("constructor-has") pos-label sk fk) sk)
...
((name ("constructor-has") other sk fk) fk)))
(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 mut-labels interfaces mutables immutables . stack)
(emit-record name constructor name?)))))))))))
(define-syntax emit-record
(syntax-rules ()
((emit-record (labels . stack) name (make-name pos-label ...) name?)
(add-temporaries labels
(emit-record name (make-name pos-label ...) name? stack)))
((emit-record (labels . stack) name make-name name?)
(emit-record (labels . stack) name (make-name . labels) name?))
((emit-record ((label temp) ...) name (make-name pos-label ...) name? stack)
(add-temporaries (pos-label ...)
(emit-record ((label temp) ...) (label ...) (temp ...) name make-name name? stack)))
((emit-record ((pos-label pos-temp) ...) ((label temp) ...) labels temps
name make-name name? ((mut-label ...)
((super super-label ...) ...)
((label** get-label** set-label!**) ...)
((label* get-label*) ...) . stack))
(begin
(define (maker . labels)
(let ((mut-label (box mut-label))
...)
(list <record>
(lambda (interface sk fk) ; match vtable
(case interface
((name) (sk label ...))
((super) (sk super-label ...))
...
(else (fk))))
(lambda (super-tag fields-k) ; for polymorphic update
(let ((mut-label (unbox mut-label))
...)
(fields-k
(case super-tag
((name) (lambda labels
(maker . labels)))
((super) (lambda (super-label ...)
(maker . labels)))
...))))
(lambda () ; for printing
(let ((mut-label (unbox mut-label))
...)
(list 'name (list 'label label) ...))))))
(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 "Record" (show record)
"does not support selector for"
'(name label**))))))
...
(define-if get-label*
(lambda (record)
((cadr record) 'name
(lambda labels label*)
(lambda () (error "Record" (show record)
"does not support selector for"
'(name label*))))))
...
(define-if set-label!**
(lambda (record val)
((cadr record) 'name
(lambda labels
(begin (set-box! label** val)
record))
(lambda () (error "Record" (show record)
"does not support mutator for"
'(name label**))))))
...
(define-syntax name
(syntax-rules (name label ... super ...)
((name ("info") k)
(syntax-apply k (make-name ((super super-label ...) ...) label ...)))
((name ("labels") k) (syntax-apply k labels))
((name ("has") label sk fk) sk)
...
((name ("has") other sk fk) fk)
((name ("project") temps label k) (syntax-apply k temp))
...
((name ("mutable?") mut-label sk fk) sk)
...
((name ("mutable?") other sk fk) fk)
((name ("=") name sk fk) sk)
((name ("=") other sk fk) fk)
((name ("match") val bindings sk fk)
(match-record val (name . bindings) labels (pos-label ...) 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 define-if
(syntax-rules ()
((define-if #f binding) (begin))
((define-if name binding) (define name binding))))
(define-syntax define-syntax-if
(syntax-rules ()
((define-syntax-if #f binding) (begin))
((define-syntax-if name binding) (define-syntax name binding))))
(define (record? x)
(and (pair? x)
(eq? (car x) <record>)))
(define (record->sexp r)
((cadddr r)))
(define (show x)
(if (record? x)
(record->sexp x)
x))
(define-syntax extract-labels
(syntax-rules ()
((extract-labels stack fields pos-labels name k)
(syntax-map fields (extract-label)
(syntax-filter (if-not-in-constructor? name)
(syntax-append-after pos-labels
(push-result stack k)))))))
(define-syntax extract-label
(syntax-rules ()
((extract-label (label . stuff) k) (syntax-apply k label))
((extract-label label k) (syntax-apply k label))))
(define-syntax if-not-in-constructor?
(syntax-rules ()
((if-not-in-constructor? label name sk fk)
(name ("constructor-has") label
fk
sk))))
(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 c) sk fk) fk)
((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?)
(syntax-map (dress-mutable)
(push-result stack k))))))
(define-syntax if-mutable?
(syntax-rules ()
((if-mutable? (a b c) sk fk) sk)
((if-mutable? (a) sk fk) sk)
((if-mutable? other sk fk) fk)))
(define-syntax dress-mutable
(syntax-rules ()
((dress-mutable (a b c) k) (syntax-apply k (a b c)))
((dress-mutable (a) k) (syntax-apply k (a #f #f)))))
(define-syntax get-interfaces
(syntax-rules ()
((get-interfaces stack supers k)
(syntax-foldl () (insert-interfaces) supers
(push-result stack k)))))
(define-syntax insert-interfaces
(syntax-rules ()
((insert-interfaces acc name k)
(name ("info")
(emit-interfaces acc name k)))))
(define-syntax emit-interfaces
(syntax-rules ()
((emit-interfaces (make-name supers label ...) acc name k)
(syntax-foldr acc (insert-interface) supers
(insert-interface (name label ...) k)))))
(define-syntax insert-interface
(syntax-rules ()
((insert-interface acc (name label ...) k)
(contains-interface? name acc
(syntax-apply k acc)
(recolor (name label ...) acc
(syntax-cons acc k))))))
(define-syntax contains-interface?
(syntax-rules ()
((contains-interface? name () sk fk) fk)
((contains-interface? name ((name* . stuff) . interfaces) sk fk)
(name* ("=") name
sk
(contains-interface? name interfaces sk fk)))))
(define-syntax recolor
(syntax-rules ()
((recolor interface interfaces k)
(syntax-foldr interface (absorb-colors) interfaces k))))
(define-syntax absorb-colors
(syntax-rules ()
((absorb-colors (name . labels) (name* . labels*) k)
(syntax-map labels (recolor-label (name* . labels*))
(syntax-cons-after name k)))))
(define-syntax recolor-label
(syntax-rules ()
((recolor-label label (name* . labels*) k)
(name* ("has") label
(name* ("project") labels* label k)
(syntax-apply k label)))))
(define-syntax union-mutables
(syntax-rules ()
((union-mutables (interfaces ((mutable . stuff) ...) . stack) k)
(syntax-foldr (() ()) (insert-mutables) interfaces
(insert-mutables ("main" mutable ...)
(syntax-car
(syntax-reverse
(push-result (interfaces ((mutable . stuff) ...) . stack) k))))))))
(define-syntax insert-mutables
(syntax-rules ()
((insert-mutables (accum already) (name . labels) k)
(syntax-foldl accum (insert-mutable name already) labels
(syntax-cons ((name . already)) k)))))
(define-syntax insert-mutable
(syntax-rules ()
((insert-mutable accum label "main" () k)
(syntax-apply k (label . accum)))
((insert-mutable accum label super () k)
(super ("mutable?") label
(syntax-apply k (label . accum))
(syntax-apply k accum)))
((insert-mutable accum label name (name* . names*) k)
(name* ("has") label
(syntax-apply k accum)
(insert-mutable accum label name names* k)))))
(define-syntax union-labels
(syntax-rules ()
((union-labels (labels mut-labels interfaces . stack) k)
(syntax-foldr (() ()) (insert-labels) interfaces
(insert-labels (main . labels)
(syntax-car
(syntax-reverse
(push-result (mut-labels interfaces . stack) k))))))))
(define-syntax insert-labels
(syntax-rules ()
((insert-labels (accum already) (name . labels) k)
(syntax-foldl accum (insert-label already) labels
(syntax-cons ((name . already)) k)))))
(define-syntax insert-label
(syntax-rules ()
((insert-label accum label () k)
(syntax-apply k (label . accum)))
((insert-label accum label (name* . names*) k)
(name* ("has") label
(syntax-apply k accum)
(insert-label accum label names* 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 match-record
(syntax-rules ()
((match-record val (name . pats) labels pos-labels sk fk)
(let ((fail (lambda () fk)))
(if (record? val)
(match-fields (cadr val) (name . pats) labels pos-labels sk fail)
(fail))))))
(define-syntax match-fields
(syntax-rules ()
((match-fields val (name (label pat) ...) labels pos-labels sk fail)
(match-labels ((label . pat) ...) labels val name sk fail))
((match-fields val (name ("pos") . pats) labels pos-labels sk fail)
(syntax-zip pos-labels pats
(match-labels labels val name sk fail)
(syntax-error "Wrong number of patterns in positional match" (name : . pats)
"Matchable fields are in order" pos-labels)))
((match-fields val (name . pats) . rest)
(syntax-error "Illegal record pattern for" val "in" (name . pats)))))
(define-syntax match-labels
(syntax-rules ()
((match-labels bindings labels val name sk fail)
(order labels bindings _
(match-labels val name sk fail)))
((match-labels ((label . pat) ...) val name sk fail)
(syntax-map ((label . pat) ...) (decorate-mutable name)
(match-positions val name sk fail)))))
(define-syntax decorate-mutable
(syntax-rules ()
((decorate-mutable (label . pat) name k)
(name ("mutable?") label
(syntax-apply k (box pat))
(syntax-apply k pat)))))
; This works and is relatively simple. Below is slight optimization
; that only introduces new variables for non-variable patterns.
; That mostly makes expanded code more readable for debugging.
; (define-syntax match-positions*
; (syntax-rules ()
; ((match-positions pats val name sk fail)
; (add-temporaries pats
; (match-positions val name pats sk fail)))
; ((match-positions ((pat temp) ...) val name pats sk fail)
; (val 'name
; (lambda (temp ...)
; (match-each ((pat temp) ...) sk fail))
; fail))))
(define-syntax match-positions
(syntax-rules ()
((match-positions pats val name sk fail)
(syntax-foldr (() ()) (separate-variable-or-pattern) pats
(match-positions val name pats sk fail)))
((match-positions ((var ...) ((pat temp) ...)) val name pats sk fail)
(val 'name
(lambda (var ...)
(match-each ((pat temp) ...) sk fail))
fail))))
(define-syntax match-each
(syntax-rules ()
((match-each () sk fail)
sk)
((match-each ((pat var) . bindings) sk fail)
(match-var var
(pat (match-each bindings sk fail))
(_ (fail))))))
(define-syntax separate-variable-or-pattern
(syntax-rules (_)
((separate-variable-or-pattern (vars pats-temps) _ k)
(syntax-apply k ((temp* . vars) ((_ temp*) . pats-temps))))
((separate-variable-or-pattern (vars pats-temps) pat* k)
(if-symbol? pat*
(syntax-apply k ((pat* . vars) pats-temps))
(syntax-apply k ((temp* . vars) ((pat* temp*) . pats-temps)))))))
(define-syntax update-help
(syntax-rules ()
((update-help all-labels record (name (label binding) ...))
(order all-labels ((label . binding) ...) (#f)
(syntax-map (insert-patterns)
(update-help all-labels record name))))
((update-help ((label pat binding) ...) all-labels record name)
(match-let (((name (label pat) ...) record))
((caddr record) 'name
(lambda (k) (k binding ...)))))))
(define-syntax update.-help
(syntax-rules ()
((update.-help labels name val bindings)
(order labels bindings (#f)
(syntax-map (insert-patterns)
(update.-help name val))))
((update.-help ((label pat binding) ...) name val)
(match-let (((name (label pat) ...) val))
(name (label binding) ...)))))
(define-syntax insert-patterns
(syntax-rules ()
((insert-patterns (label . (#f)) k) (syntax-apply k (label temp temp)))
((insert-patterns (label . binding) k) (syntax-apply k (label _ binding)))))
(define-syntax update!-help
(syntax-rules ()
((update!-help (((label exp) set-label!) ...) exp* name)
(let ((val exp*))
(match val
((name (label (set! set-label!)) ...)
(set-label! exp)
...
val))))))
(define-syntax extend-help
(syntax-rules ()
((extend-help labels stack)
(add-temporaries labels
(extend-help labels stack)))
((extend-help ((label temp) ...) labels ((export-name . bindings) . stack))
(syntax-filter ((label temp) ...) (if-not-member? bindings)
(emit-extend ((label temp) ...) export-name bindings stack)))))
(define-syntax emit-extend
(syntax-rules ()
((emit-extend ((label* temp*) ...) ((label temp) ...) export-name
bindings (name exp imports))
(let ((val exp))
(match-let (((name (label temp) ...) val))
(extend 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*) . bindings) sk fk)
(if-free= label label*
fk
(if-not-member? (label . stuff) bindings sk fk)))))
; Boxes for mutable fields
(define-view box (set!)
(match val sk fk
((box (set! m))
(if (box? val)
(let ((m (lambda (v) (set-box! val v) val))) sk)
fk))
((box pat) (if (box? val)
(match (unbox val)
(pat sk)
(_ fk))
fk)))
((box exp) (cons exp '())))
(define box? pair?)
(define unbox car)
(define (set-box! box value) (set-car! box value))
(define-view setter ()
(match val sk fk
((setter pat)
(syntax-error "No setter available for pattern" (setter pat)))))
;=============================================================================
; 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
;-------------------------------------------------------------------------------
; Elements may be left out if not desired, as the following examples illustrate:
(define-record-type node (make-node left right)) ; no predicates bound, fields listed in the
(define-record-type leaf (make-leaf value)) ; constructor do not have to be repeated in
; the field clause list unless mutable or
; we want to bind getters or setters
(define-record-type monday) ; no predicates or constructors bound
(define-record-type tuesday #f tuesday?) ; predicate bound, no constructor
(define-record-type node make-node ; make-node has default argument order
#f ; no predicate is bound
(left left #f) ; fields are mutable, but no setters are bound
(right right #f)) ; also note that field labels may be punned
(define-record-type node make-node #f
(left) ; short for (left #f #f) indicating mutable field
(right))
(define-record-type node (make-node left right) #f ; left and right are immutable fields
extra) ; short for (extra #f) indicating immutable field
;-------------------------------------------------------------------------------
; Subtyping:
(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) ; 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) (y))
(define-record-type (point3 point2) #f #f (x) (y) (z))
(define p (point3 (x 1) (y 1) (z 3)))
(show (record-update point2 p (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. point2 p (y 5))) ;==> (point2 (x 1) (y 5)) -- monomorphic update
(show p) ;==> (point3 (x 1) (y 1) (z 3)) -- original unaffected
(show (record-update! point2 p (y 5))) ;==> (point3 (x 1) (y 5) (z 3)) -- destructive update
(show p) ;==> (point3 (x 1) (y 5) (z 3)) -- original updated
;-------------------------------------------------------------------------------
; Record extension:
(define c (color (hue 'green)))
(define p (point (x 1) (y 2)))
(show
(extend ((point p)
(color c))
(color-point (x 5)
(info 'hi)))) ;==> (color-point (hue green) (x 5) (y 2) (info hi))
[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
[3] Andrew Wright and Bruce Duba, Pattern Matching for Scheme, Rice University 1994
Bruce Hauman, The plt-match.ss MzScheme library, http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php
Manual Serrano, The Bigloo Pattern Matching Facilities, Bigloo User Manual, July 2004
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.