Below is an implementation in Dybvig's portable syntax-case, using the
included macro system. Tested on Petite Chez v6.9c.
Andre
;============================================================================================
; DEPENDENCIES:
;
; Andre van Tonder, 2005.
;
; This section contains an implementation of SRFI-9 and the
; necessary procedures from SRFI-1. May be omitted if these
; SRFIs are already available.
;
;============================================================================================
; Only the necessary procedures adapted from the SRFI-1 reference
; implementation. If you have SRFI-1, this may be omitted. Here I
; didn't bother with optional arguments since only fixed-arity
; versions are needed.
(module srfi-1 (s1:assoc
s1:lset-intersection
s1:lset-difference
s1:delete-duplicates
s1:fold-right
s1:filter
s1:member)
(define (find pred list)
(cond ((find-tail pred list) => car)
(else #f)))
(define (s1:member x lis =)
(find-tail (lambda (y) (= x y)) lis))
(define (find-tail pred list)
(let lp ((list list))
(and (not (null-list? list))
(if (pred (car list)) list
(lp (cdr list))))))
(define (s1:assoc x lis =)
(find (lambda (entry) (= x (car entry))) lis))
(define (s1:lset-intersection = lis1 . lists)
(let ((lists (delete lis1 lists eq?)))
(cond ((any null-list? lists) '())
((null? lists) lis1)
(else (s1:filter (lambda (x)
(every (lambda (lis) (s1:member x lis =))
lists))
lis1)))))
(define (s1:lset-difference = lis1 . lists)
(let ((lists (s1:filter pair? lists)))
(cond ((null? lists) lis1)
((memq lis1 lists) '())
(else (s1:filter (lambda (x)
(every (lambda (lis) (not (s1:member x lis =)))
lists))
lis1)))))
(define (every pred list)
(let lp ((list list))
(or (not (pair? list))
(and (pred (car list))
(lp (cdr list))))))
(define (delete x lis =)
(s1:filter (lambda (y) (not (= x y))) lis))
(define (any pred lis1)
(and (not (null-list? lis1))
(let lp ((head (car lis1)) (tail (cdr lis1)))
(if (null-list? tail)
(pred head)
(or (pred head) (lp (car tail) (cdr tail)))))))
(define (s1:delete-duplicates lis elt=)
(let recur ((lis lis))
(if (null-list? lis) lis
(let* ((x (car lis))
(tail (cdr lis))
(new-tail (recur (delete x tail elt=))))
(if (eq? tail new-tail) lis (cons x new-tail))))))
(define (s1:fold-right kons knil lis1)
(let recur ((lis lis1))
(if (null-list? lis) knil
(let ((head (car lis)))
(kons head (recur (cdr lis)))))))
(define null-list? null?)
(define (s1:filter pred lis)
(let recur ((lis lis))
(if (null-list? lis) lis
(let ((head (car lis))
(tail (cdr lis)))
(if (pred head)
(let ((new-tail (recur tail)))
(if (eq? tail new-tail) lis
(cons head new-tail)))
(recur tail))))))
)
;======================================================================================
; SRFI-9 implementation, based on implementation by Felix Winkelmann.
; If you have SRFI-9, this may be omitted.
(module srfi-9 (s9:define-record-type)
(import srfi-1)
(define-syntax (s9:define-record-type x)
(syntax-case x ()
((_ t (conser vars ...) pred slots ...)
(syntax-case #'(slots ...) ()
(((slotnames . _) ...)
(with-syntax ((t (datum->syntax-object #'t (gensym)))
((slotvars ...) (map (lambda (sname)
(if (s1:member sname #'(vars ...) literal-identifier=?)
sname
#''<undefined>))
#'(slotnames ...))))
(with-syntax (((accforms ...)
(let loop ((slots #'(slots ...)) (i 2))
(if (null? slots)
#'()
(with-syntax ((ii i)
((rest ...) (loop (cdr slots) (+ 1 i))))
(syntax-case (car slots) ()
((name get set)
#'((define (get x)
(vector-ref x ii))
(define (set x y)
(vector-set! x ii y))
rest ...))
((name get)
#'((define (get x)
(vector-ref x ii))
rest ...))))))))
#'(begin
(define (conser vars ...) (vector '<record> 't slotvars ...))
(define (pred x) (and (vector? x)
(>= (vector-length x) 2)
(eqv? '<record> (vector-ref x 0))
(eqv? 't (vector-ref x 1))))
accforms ...))))))))
) ; srfi-9
;===========================================================================================
; SRFI-57: RECORDS IMPLEMENTATION IN PORTABLE SYNTAX-CASE:
;
; Andre van Tonder, 2005.
;
;============================================================================================
(module registry (register
make-entry
lookup-entry
lookup-scheme?
lookup-getter
lookup-setter
lookup-labels
lookup-supers
lookup-copier
lookup-predicate)
(import srfi-1)
(import srfi-9)
(define reg '())
(s9:define-record-type entry
(make-entry name
is-scheme?
predicate
supers
labels
pos-labels
fields
copier)
entry?
(name entry.name)
(is-scheme? entry.is-scheme?)
(predicate entry.predicate)
(supers entry.supers)
(labels entry.labels)
(pos-labels entry.pos-labels)
(fields entry.fields)
(copier entry.copier))
(define (register name entry)
(cond ((s1:assoc name reg literal-identifier=?)
=> (lambda (pair)
(set-cdr! pair entry)))
(else
(set! reg (cons (cons name entry)
reg)))))
(define (lookup-entry name)
(s1:assoc name reg literal-identifier=?))
(define (lookup-getter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
literal-identifier=?)
=> cadr)
(else #f)))
(define (lookup-setter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
literal-identifier=?)
=> caddr)
(else #f)))
(define (lookup-scheme? name) (entry.is-scheme? (cdr (lookup-entry name))))
(define (lookup-labels name) (entry.labels (cdr (lookup-entry name))))
(define (lookup-supers name) (entry.supers (cdr (lookup-entry name))))
(define (lookup-copier name) (entry.copier (cdr (lookup-entry name))))
(define (lookup-predicate name) (entry.predicate (cdr (lookup-entry name))))
) ; registry
(module portability (syntax->list)
(define (syntax->list x)
(syntax-case x ()
(() '())
((h . t) (cons #'h
(syntax->list #'t)))))
)
(module helpers (parse-declaration
build-record
extend-predicates
extend-copiers
extend-accessors
populate
define-generic
make-generic
define-method
any?)
(import registry)
(import srfi-1)
(import srfi-9)
(import portability)
(define-syntax parse-declaration
(syntax-rules ()
((parse-declaration is-scheme? (name super ...) (constructor pos-label ...) predicate field-clause ...)
(build-record (constructor pos-label ...) #f (super ...) (field-clause ...) name predicate is-scheme?))
((parse-declaration is-scheme? (name super ...) constructor predicate field-clause ...)
(build-record (constructor) #t (super ...) (field-clause ...) name predicate is-scheme?))
((parse-declaration is-scheme? (name super ...) constructor-clause)
(parse-declaration is-scheme? (name super ...) constructor-clause #f))
((parse-declaration is-scheme? (name super ...))
(parse-declaration is-scheme? (name super ...) #f #f))
((parse-declaration is-scheme? name . rest)
(parse-declaration is-scheme? (name) . rest))))
(define-syntax build-record
(let ()
(define (build-record stx)
(syntax-case stx ()
((build-record (constructor pos-label ...)
default-order?
(super ...)
((field-label . accessors) ...)
name
predicate
is-scheme?)
(with-syntax
(((label ...)
(s1:delete-duplicates (s1:fold-right append
(syntax->list #'(pos-label ... field-label ...))
(map lookup-labels
(syntax->list #'(super ...))))
literal-identifier=?))
((super ...)
(s1:delete-duplicates (s1:fold-right append
'()
(map lookup-supers
(syntax->list #'(super ...))))
literal-identifier=?)))
(with-syntax
(((pos-label ...)
(if (syntax-object->datum #'default-order?)
#'(label ...)
#'(pos-label ...)))
(((field-label getter setter) ...)
(append (map augment-field
(syntax->list #'((field-label . accessors) ...)))
(map (lambda (label)
(maybe-generate #'name `(,label getter setter)))
(s1:lset-difference literal-identifier=?
(syntax->list #'(label ...))
(syntax->list #'(field-label ...)))))))
(with-syntax ((supers #'(super ...))
((pos-temp ...) (generate-temporaries #'(pos-label ...)))
((constructor predicate maker copier)
(maybe-generate #'name `(,#'constructor ,#'predicate maker copier))))
(begin
(register #'name (make-entry #'name
(syntax-object->datum #'is-scheme?)
#'predicate
(syntax->list #'(super ... name))
(syntax->list #'(label ...))
(syntax->list #'(pos-label ...))
(map syntax->list
(syntax->list #'((field-label getter setter) ...)))
#'copier))
(if (syntax-object->datum #'is-scheme?)
#'(begin
(define-generic (predicate x) (lambda (x) #f))
(define-generic (getter x))
...
(define-generic (setter x v))
...
(define-generic (copier x)))
#'(begin
(s9:define-record-type internal-name
(maker field-label ...)
predicate
(field-label getter setter) ...)
(define constructor
(lambda (pos-temp ...)
(populate name maker (field-label ...) (pos-label pos-temp) ...)))
(extend-predicates supers predicate)
(extend-accessors supers field-label predicate getter setter)
...
(define (copier x)
(maker (getter x) ...))
(extend-copiers supers copier predicate)
(define-method (show (r predicate))
(list 'name
(list 'field-label (getter r))
...))
(define-syntax name
(syntax-rules ()
((name . bindings) (populate name maker (field-label ...) . bindings))))
))))))))) ; build-record
(define (maybe-generate context maybe-identifiers)
(map (lambda (elem)
(if (identifier? elem)
elem
(datum->syntax-object context (gensym))))
maybe-identifiers))
(define (augment-field clause)
(syntax-case clause ()
((label) (maybe-generate #'label `(,#'label getter setter)))
((label getter) (maybe-generate #'label `(,#'label ,#'getter setter)))
((label getter setter) (maybe-generate #'label `(,#'label ,#'getter ,#'setter)))))
build-record))
(define-syntax extend-predicates
(lambda (stx)
(syntax-case stx ()
((extend-predicates (super ...) new-type)
(with-syntax (((predicate ...) (map lookup-predicate
(syntax->list #'(super ...)))))
#'(begin
(define-method predicate (new-type) (x) any?)
...))))))
(define-syntax extend-copiers
(lambda (stx)
(syntax-case stx ()
((extend-copiers (super ...) copy new-type)
(with-syntax (((copier ...) (map lookup-copier
(syntax->list #'(super ...)))))
#'(begin
(define-method copier (new-type) (x) copy)
...))))))
(define-syntax extend-accessors
(lambda (stx)
(syntax-case stx ()
((extend-accessors (super ...) label new-type selector modifier)
(with-syntax (((getter ...) (s1:filter (lambda (id)
(not (eqv? id #f)))
(map (lambda (super)
(lookup-getter super #'label))
(syntax->list #'(super ...)))))
((setter ...) (s1:filter (lambda (id)
(not (eqv? id #f)))
(map (lambda (super)
(lookup-setter super #'label))
(syntax->list #'(super ...))))))
#'(begin
(define-method getter (new-type) (x) selector)
...
(define-method setter (new-type any?) (x v) modifier)
...))))))
(define-syntax populate
(lambda (stx)
(define (order name ordering bindings default)
(if (null? (s1:lset-difference literal-identifier=?
(map car bindings)
ordering))
(map (lambda (label)
(cond ((s1:assoc label bindings literal-identifier=?) => (lambda (x) x))
(else `(,label ,default))))
ordering)
(error 'populate "Bindings ~s contains illegal labels. Legal labels for record type ~s are ~s"
(syntax-object->datum bindings)
(syntax-object->datum name)
(syntax-object->datum ordering))))
(syntax-case stx ()
((populate name maker labels . bindings)
(with-syntax ((((label exp) ...) (order #'name
(syntax->list #'labels)
(map syntax->list
(syntax->list #'bindings))
#''<undefined>)))
#'(maker exp ...))))))
; Simple generic functions suitable for our disjoint base record types:
(define-syntax define-generic
(syntax-rules ()
((define-generic (name arg ...))
(define-generic (name arg ...)
(lambda (arg ...) (error "Inapplicable method:" 'name
"Arguments:" (show arg) ... ))))
((define-generic (name arg ...) proc)
(define name (make-generic (arg ...) proc)))))
(define-syntax define-method
(syntax-rules ()
((define-method (generic (arg pred?) ...) . body)
(define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body)))
((define-method generic (pred? ...) (arg ...) procedure)
(let ((next ((generic) 'get-proc))
(proc procedure))
(((generic) 'set-proc)
(lambda (arg ...)
(if (and (pred? arg) ...)
(proc arg ...)
(next arg ...))))))))
(define-syntax make-generic
(syntax-rules ()
((make-generic (arg arg+ ...) default-proc)
(let ((proc default-proc))
(case-lambda
((arg arg+ ...)
(proc arg arg+ ...))
(()
(lambda (msg)
(case msg
((get-proc) proc)
((set-proc) (lambda (new)
(set! proc new)))))))))))
(define (any? x) #t)
) ; helpers
(module records (define-record-type
define-record-scheme
record-update
record-update!
record-compose
show)
(import srfi-1)
(import registry)
(import portability)
(import helpers)
(define-syntax define-record-type
(syntax-rules ()
((define-record-type . body)
(parse-declaration #f . body))))
(define-syntax define-record-scheme
(syntax-rules ()
((define-record-scheme . body)
(parse-declaration #t . body))))
(define-syntax record-update!
(lambda (stx)
(syntax-case stx ()
((_ record name (label exp) ...)
(with-syntax (((setter ...)
(map (lambda (label)
(lookup-setter #'name label))
(syntax->list #'(label ...)))))
#'(let ((r record))
(setter r exp)
...
r))))))
(define-syntax record-update
(lambda (stx)
(syntax-case stx ()
((_ record name (label exp) ...)
(if (lookup-scheme? #'name)
(with-syntax ((copier (lookup-copier #'name)))
#'(let ((new (copier record)))
(record-update! new name (label exp) ...)))
#'(record-compose (name record) (name (label exp) ...)))))))
(define-syntax record-compose
(lambda (stx)
(syntax-case stx ()
((record-compose (export-name (label exp) ...))
#'(export-name (label exp) ...))
((record-compose (import-name record) import ... (export-name (label exp) ...))
(with-syntax
(((copy-label ...)
(s1:lset-intersection literal-identifier=?
(lookup-labels #'export-name)
(s1:lset-difference literal-identifier=?
(lookup-labels #'import-name)
(syntax->list #'(label ...))))))
(with-syntax (((getter ...)
(map (lambda (label)
(lookup-getter #'import-name label))
(syntax->list #'(copy-label ...)))))
#'(let ((r record))
(record-compose import ...
(export-name (copy-label (getter r))
...
(label exp)
...)))))))))
(define-generic (show x)
(lambda (x) x))
) ; records
