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

Re: Update available-- possibly last before finalization



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.

Regards
Andre

(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 ...))
                                                 sname
                                                 #'(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 ...) ] ) ) ) ) ] )
            #'(begin
                (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 ...) ) ) ] ) ] ) )