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

Re: Update available-- possibly last before finalization

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.

On Fri, 10 Dec 2004, Felix Winkelmann wrote:
Andre van Tonder wrote:
On Fri, 10 Dec 2004, Felix Winkelmann wrote:

From what my experiments show the current SRFI-57 reference implementation
does *not* work on systems that provide a non-generative SRFI-9, or non-
generative native records.

I'm not sure why that should be. Would you mind saying a bit more on this?

Here a simple implementation of SRFI-9, using syntax-case:

[code snipped]

Hi Felix,

The following modification of your code works, but is generative, and so probably misses the point of what you were trying to achieve. To get nongenerativity, the underlying SRFI-9-like interface should probably be passed an extra identifier to be used as tag, instead of creating a unique tag as done below.


(define <record> (list 'vector))

(define-syntax (srfi-9:define-record-type x)
  (define (memi id ids)
    (and (not (null? ids))
         (or (free-identifier=? id (car ids))
             (memi id (cdr ids)) ) ) )
  (syntax-case x ()
    [(_ t (conser vars ...) pred slots ...)
     (syntax-case #'(slots ...) ()
       [((slotnames . _) ...)
        (with-syntax ([(slotvars ...) (map (lambda (sname)
                                             (if (memi sname #'(vars ...))
                                                 #'(void) ) )
                                           #'(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 ...) ] ) ) ) ) ] )
                (define generated-tag (cons #f #f))
(define (conser vars ...) (vector <record> generated-tag slotvars ...))
                (define (pred x) (and (vector? x)
                                      (eq? <record> (vector-ref x 0))
(eq? generated-tag (vector-ref x 1))))
                accforms ...) ) ) ] ) ] ) )