[long] accessing fields through identifier macros
marcomaggi
I am releasing the attached code in the public domain,
just because I think someone can find it useful. I tested
it under LIMY Schemes (R6RS Larceny, Ikarus, Mosh, Ypsilon).
This macro is also part of the (records) library in the
Nausicaa distribution (although I have not yet pushed the
code to the public repository).
The `with-record-fields' syntax allows access to the
fields of a record using identifier macros; it is similar to
Common Lisp's `with-slots'. For example, if the record
types hierarchy is:
(define-record-type <alpha>
(fields (mutable a)
(immutable b)))
(define-record-type <beta>
(parent <alpha>)
(fields (mutable c)
(mutable d)))
the macro use:
(let ((o (make-<beta> 1 2 3 4)))
(with-record-fields ((a <beta> o)
(c <beta> o))
(set! c 9)
(list a c)))
=> (1 9)
is equivalent to:
(let ((o (make-<beta> 1 2 3 4)))
(<beta>-c-set! o 9)
(list (<alpha>-a o)
(<beta>-c o)))
=> (1 9)
Another example for the record types:
(define-record-type <alpha>
(fields (mutable a)
(mutable b)))
(define-record-type <beta>
(fields (mutable c)
(mutable d)))
shows how to bind multiple identifiers for the same record:
(let ((p (make-<alpha> 1 2))
(q (make-<beta> 3 4)))
(with-record-fields (((a b) <alpha> p)
((c d) <beta> q))
(list a b c d)))
=> (1 2 3 4)
and, for the same record types, the following example shows
how to give different names to the same fields of different
records:
(let ((p (make-<alpha> 1 2))
(q (make-<alpha> 3 4)))
(with-record-fields ((((a1 a) (b1 b)) <alpha> p)
(((a2 a) (b2 b)) <alpha> q))
(list a1 a2 b1 b2)))
=> (1 3 2 4)
-- Syntax: with-record-fields <field-bindings> <body>
Bind the accessors and mutators of multiple records to
identifier macros; in the region of these bindings,
evaluate the <body>.
<body> is a normal body, while <field-bindings> can be
of one of the following forms:
((((<var-name> <field-name>) ...) <record name> <expr>)
<field-bindings> ...)
(((<field-name> ...) <record name> <expr>)
<field-bindings> ...)
((<field-name> <record name> <expr>)
<field-bindings> ...)
description of elements follows:
<record name>
Is the record type name as described in the
definition of `define-record-type'.
<var-name>
An identifier which is bound to the identifier
syntax; when not given, it defaults to <field-name>
itself.
<field-name>
Must be a symbol representing a valid field name
for the record type associated to <record name>.
<expr>
Must be an expression evaluating to a record whose
type descriptor is associated to <record name>.
It is evaluated only once.
To run the code save the library in the file "proof.sls"
and the program in the file "proof.sps"; run the program
setting appropriately the library search path for the Scheme
implementation, so that it can find the library.
;;; library
(library (proof)
(export
<alpha> make-<alpha>
<beta> make-<beta>
<gamma> make-<gamma>)
(import (rnrs))
(define-record-type <alpha>
(fields (mutable a)
(immutable b)
(mutable c)))
(define-record-type <beta>
(parent <alpha>)
(fields (mutable d)
(immutable e)
(mutable f)))
(define-record-type <gamma>
(parent <beta>)
(fields (mutable g)
(immutable h)
(mutable i)))
)
;;; end of file
;;; program
(import (rnrs)
(for (proof) run expand))
(define-syntax with-record-fields
(syntax-rules ()
((_ () ?form0 ?form ...)
(begin ?form0 ?form ...))
((_ ((((?var-name ?field-name) ...) ?record-name ?expr))
?form0 ?form ...)
(let-syntax
((dummy (lambda (stx)
(define (vector-index item vec)
(let ((len (vector-length vec)))
(let loop ((i 0))
(and (< i len)
(if (eq? item (vector-ref vec i))
i
(loop (+ i 1)))))))
(define (%record-field-accessor rtd-name rtd field-name)
(if rtd
(let ((idx (vector-index field-name (record-type-field-names
rtd))))
(if idx
(record-accessor rtd idx)
(%record-field-accessor rtd-name (record-type-parent rtd)
field-name)))
(assertion-violation #f
(string-append "unknown field name in record type hierarchy of \""
(symbol->string rtd-name) "\"")
field-name)))
(define (%record-field-mutator rtd-name rtd field-name)
(if rtd
(let ((idx (vector-index field-name (record-type-field-names
rtd))))
(cond ((not idx)
(%record-field-mutator rtd-name (record-type-parent rtd) field-
name))
((record-field-mutable? rtd idx)
(record-mutator rtd idx))
(else
(lambda args
(assertion-violation #f
(string-append "attempt to mutate immutable field for record
\""
(symbol->string (record-type-name rtd)) "\"")
field-name)))))
(assertion-violation #f
(string-append "unknown field name in record type hierarchy of \""
(symbol->string rtd-name) "\"")
field-name)))
(syntax-case stx ()
((_ ?kontext)
(with-syntax
(((EXPR) (datum->syntax #'?kontext '(?expr)))
((VAR (... ...))
(datum->syntax #'?kontext '(?var-name ...)))
((ACCESSOR (... ...))
(datum->syntax #'?kontext
(list
(%record-field-accessor (quote ?record-name)
(record-type-descriptor ?record-name)
(quote ?field-name))
...)))
((MUTATOR (... ...))
(datum->syntax #'?kontext
(list
(%record-field-mutator (quote ?record-name)
(record-type-descriptor ?record-name)
(quote ?field-name))
...)))
((FORMS (... ...))
(datum->syntax #'?kontext '(?form0 ?form ...))))
(syntax (let ((the-record EXPR))
(let-syntax
((VAR (identifier-syntax
(_ ('ACCESSOR the-record))
((set! _ e) ('MUTATOR the-record e))))
(... ...))
FORMS (... ...))))))))))
(dummy ?record-name)))
((_ ((((?var-name0 ?field-name0) ...) ?record-name0 ?expr0) ?
bindings ...) ?form0 ?form ...)
(with-record-fields ((((?var-name0 ?field-name0) ...) ?record-
name0 ?expr0))
(with-record-fields (?bindings ...) ?form0 ?form ...)))
((_ (((?field-name0 ...) ?record-name0 ?expr0) ?bindings ...) ?
form0 ?form ...)
(with-record-fields ((((?field-name0 ?field-name0) ...) ?record-
name0 ?expr0))
(with-record-fields (?bindings ...) ?form0 ?form ...)))
((_ ((?field-name0 ?record-name0 ?expr0) ?bindings ...) ?form0 ?
form ...)
(with-record-fields ((((?field-name0 ?field-name0)) ?record-
name0 ?expr0))
(with-record-fields (?bindings ...) ?form0 ?form ...)))))
(let ((o (make-<gamma> 1 2 3
4 5 6
7 8 9)))
(with-record-fields ((a <gamma> o))
a)
(with-record-fields (((a) <gamma> o))
a)
(with-record-fields ((a <gamma> o)
(b <gamma> o)
(c <gamma> o)
(d <gamma> o)
(e <gamma> o)
(f <gamma> o)
(g <gamma> o)
(h <gamma> o)
(i <gamma> o))
(list a b c d e f g h i))
(with-record-fields (((a b c d e f g h i) <gamma> o))
(list a b c d e f g h i))
(with-record-fields (((a b c) <gamma> o)
(d <gamma> o)
(e <gamma> o)
((f g) <gamma> o)
(h <gamma> o)
(i <gamma> o))
(list a b c d e f g h i))
(with-record-fields (((a b c) <gamma> o)
((d e) <gamma> o)
((f g) <gamma> o)
((h i) <gamma> o))
(set! a 10)
(set! c 30)
(set! d 40)
(set! f 60)
(set! g 70)
(set! i 90)
(list a b c d e f g h i)))
(let ((o (make-<gamma> 1 2 3
4 5 6
7 8 9)))
(with-record-fields ((((augh a)) <gamma> o))
augh)
(with-record-fields ((((augh a)) <gamma> o)
(((bugh b)) <gamma> o)
(((cugh c)) <gamma> o)
(((dugh d)) <gamma> o)
(((eugh e)) <gamma> o)
(((fugh f)) <gamma> o)
(((gugh g)) <gamma> o)
(((hugh h)) <gamma> o)
(((iugh i)) <gamma> o))
(list augh bugh cugh dugh eugh fugh gugh hugh iugh))
(with-record-fields ((((ax a) (bx b) (cx c)
(dx d) (ex e) (fx f)
(gx g) (hx h) (ix i)) <gamma> o))
(list ax bx cx dx ex fx gx hx ix))
(with-record-fields ((((ax a) (bx b) (cx c)) <gamma> o)
(((dx d)) <gamma> o)
(((ex e)) <gamma> o)
(((fx f) (gx g)) <gamma> o)
(((hx h)) <gamma> o)
(((ix i)) <gamma> o))
(list ax bx cx dx ex fx gx hx ix))
(with-record-fields ((((ax a) (bx b) (cx c)) <gamma> o)
(((dx d) (ex e)) <gamma> o)
(((fx f) (gx g)) <gamma> o)
(((hx h) (ix i)) <gamma> o))
(set! ax 10)
(set! cx 30)
(set! dx 40)
(set! fx 60)
(set! gx 70)
(set! ix 90)
(list ax bx cx dx ex fx gx hx ix)))
;;; end of file
--
Marco Maggi