[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Chez implementation



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