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