ecord-type)
    s))

(define (record-type? obj)
  (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))

(define* (make-record-type type-name fields #:optional printer)
  ;; Pre-generate constructors for nfields < 20.
  (define-syntax make-constructor
    (lambda (x)
      (define *max-static-argument-count* 20)
      (define (make-formals n)
        (let lp ((i 0))
          (if (< i n)
              (cons (datum->syntax
                     x 
                     (string->symbol
                      (string (integer->char (+ (char->integer #\a) i)))))
                    (lp (1+ i)))
              '())))
      (syntax-case x ()
        ((_ rtd exp) (not (identifier? #'exp))
         #'(let ((n exp))
             (make-constructor rtd n)))
        ((_ rtd nfields)
         #`(case nfields
             #,@(let lp ((n 0))
                  (if (< n *max-static-argument-count*)
                      (cons (with-syntax (((formal ...) (make-formals n))
                                          ((idx ...) (iota n))
                                          (n n))
                              #'((n)
                                 (lambda (formal ...)
                                   (let ((s (allocate-struct rtd n)))
                                     (struct-set! s idx formal)
                                     ...
                                     s))))
                            (lp (1+ n)))
                      '()))
             (else
              (lambda args
                (if (= (length args) nfields)
                    (apply make-struct/no-tail rtd args)
                    (scm-error 'wrong-number-of-args
                               (format #f "make-~a" type-name)
                               "Wrong number of arguments" '() #f)))))))))

  (define (default-record-printer s p)
    (display "#<" p)
    (display (record-type-name (record-type-descriptor s)) p)
    (let loop ((fields (record-type-fields (record-type-descriptor s)))
               (off 0))
      (cond
       ((not (null? fields))
        (display " " p)
        (display (car fields) p)
        (display ": " p)
        (display (struct-ref s off) p)
        (loop (cdr fields) (+ 1 off)))))
    (display ">" p))

  (let ((rtd (make-struct/no-tail
              record-type-vtable
              (make-struct-layout
               (apply string-append
                      (map (lambda (f) "pw") fields)))
              (or printer default-record-printer)
              type-name
              (copy-tree fields))))
    (struct-set! rtd (+ vtable-offset-user 2)
                 (make-constructor rtd (length fields)))
    ;; Temporary solution: Associate a name to the record type descriptor
    ;; so that the object system can create a wrapper class for it.
    (set-struct-vtable-name! rtd (if (symbol? type-name)
                                     type-name
                                     (string->symbol type-name)))
    rtd))

(define (record-type-name obj)
  (if (record-type? obj)
      (struct-ref obj vtable-offset-user)
      (error 'not-a-record-type obj)))

(define (record-type-fields obj)
  (if (record-type? obj)
      (struct-ref obj (+ 1 vtable-offset-user))
      (error 'not-a-record-type obj)))

(define* (record-constructor rtd #:optional field-names)
  (if (not field-names)
      (struct-ref rtd (+ 2 vtable-offset-user))
      (primitive-eval
       `(lambda ,field-names
          (make-struct/no-tail ',rtd
                               ,@(map (lambda (f)
                                        (if (memq f field-names)
                                            f
                                            #f))
                                      (record-type-fields rtd)))))))
          
(define (record-predicate rtd)
  (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))

(define (%record-type-error rtd obj)  ;; private helper
  (or (eq? rtd (record-type-descriptor obj))
      (scm-error 'wrong-type-arg "%record-type-check"
                 "Wrong type record (want `~S'): ~S"
                 (list (record-type-name rtd) obj)
                 #f)))

(define (record-accessor rtd field-name)
  (let ((pos (list-index (record-type-fields rtd) field-name)))
    (if (not pos)
        (error 'no-such-field field-name))
    (lambda (obj)
      (if (eq? (struct-vtable obj) rtd)
          (struct-ref obj pos)
          (%record-type-error rtd obj)))))

(define (record-modifier rtd field-name)
  (let ((pos (list-index (record-type-fields rtd) field-name)))
    (if (not pos)
        (error 'no-such-field field-name))
    (lambda (obj val)
      (if (eq? (struct-vtable obj) rtd)
          (struct-set! obj pos val)
          (%record-type-error rtd obj)))))

(define (record? obj)
  (and (struct? obj) (record-type? (struct-vtable obj))))

(define (record-type-descriptor obj)
  (if (struct? obj)
      (struct-vtable obj)
      (error 'not-a-record obj)))

(provide 'record)


