Email list hosting service & mailing list manager


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))
                 ...)))))))))