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

Chez implementation

This page is part of the web mail archives of SRFI 57 from before July 7th, 2015. The new archives for SRFI 57 contain all messages, not just those from before July 7th, 2015.



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