Chez implementation Andre van Tonder 10 Dec 2004 19:42 UTC
Here is a quick adaptation that uses (Petite) Chez native records. Just prepend the reference implementation with the following code, adapted from Mike Sperber's code for MzScheme, which I believe falls under the LGPL license: ;; Based on original by Mike Sperber, contributed 12/14/2001 to MzScheme. ;; Minor adaptation for Chez Scheme by Andre van Tonder 12/10/2004. (define-syntax srfi-9:define-record-type (let () (define (filter-map proc l) (if (null? l) '() (let ((result (proc (car l)))) (if result (cons result (filter-map proc (cdr l))) (filter-map proc (cdr l)))))) (define (syntax-member? thing stuff) (cond ((null? stuff) #f) ((free-identifier=? thing (car stuff)) #t) (else (syntax-member? thing (cdr stuff))))) (lambda (x) (syntax-case x () ((_ type (constructor constructor-tag ...) predicate (field-tag accessor more ...) ...) (with-syntax ((number-of-fields (length (syntax (field-tag ...)))) ((modifier ...) (filter-map (lambda (descriptor) (syntax-case descriptor () ((field-tag accessor) #f) ((field-tag accessor modifier) (syntax modifier)))) (syntax ((field-tag accessor more ...) ...)))) ((constructor-arg ...) (map (lambda (field-tag) (if (syntax-member? field-tag (syntax (constructor-tag ...))) field-tag (syntax (void)))) (syntax (field-tag ...)))) (generic-access (syntax generic-access)) (generic-mutate (syntax generic-mutate))) (with-syntax (((accessor-proc ...) (let loop ((i 0) (fields (syntax (field-tag ...)))) (if (null? fields) '() (cons (with-syntax ((i i)) (syntax (lambda (s) (generic-access s i)))) (loop (+ 1 i) (cdr fields)))))) ((modifier-proc ...) (let loop ((i 0) (descriptors (syntax ((field-tag accessor more ...) ...)))) (if (null? descriptors) '() (syntax-case (car descriptors) () ((field-tag accessor) (loop (+ 1 i) (cdr descriptors))) ((field-tag accessor modifier) (cons (with-syntax ((i i)) (syntax (lambda (s v) (generic-mutate s i v)))) (loop (+ 1 i) (cdr descriptors))))))))) (syntax (begin (define descriptor (make-record-type "" '(field-tag ...))) (define constructor (record-constructor descriptor)) (define predicate (record-predicate descriptor)) (define accessor (record-field-accessor descriptor 'field-tag)) ... (define modifier (record-field-mutator descriptor 'field-tag)) ...)))))))))