Re: [Chicken-users] Modules + define-record-type

[Felix Winkelmann]

Grzegorz Chrupała wrote:
> Would it be possible to make define-record-type compatible again with 
> modules?
>
> Cheers,

Please replace the definition of `define-record-type' in
chicken-highlevek-macros.scm with thw following:

(define-syntax (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
                                                 #'(##sys#void) ) )
                                           #'(slotnames ...)) ] )
          (with-syntax ([(accforms ...)
                         (let loop ([slots #'(slots ...)] [i 1])
                           (if (null? slots)
                               #'()
                               (with-syntax ([ii i]
                                             [(rest ...) (loop (cdr slots) 
(add1 i))] )
                                 (syntax-case (car slots) ()
                                   [(name get set)
                                    #'((define (get x)
                                         (##sys#check-structure x 't)
                                         (##sys#slot x ii) )
                                       (define (set x y)
                                         (##sys#check-structure x 't)
                                         (##sys#setslot x ii y) )
                                       rest ...) ]
                                   [(name get)
                                    #'((define (get x)
                                         (##sys#check-structure x 't)
                                         (##sys#slot x ii) )
                                       rest ...) ] ) ) ) ) ] )
            #'(begin
                (define t 't)
                (define (conser vars ...) (##sys#make-structure 't slotvars 
...))
                (define (pred x) (##sys#structure? x 't))
                accforms ...) ) ) ] ) ] ) )



cheers,
felix