(define-module (srfi 9)
  (export define-record-type)
  (import (scheme))
  (body
   (define-syntax define-record-type
     (er-macro-transformer
      (lambda (expr rename compare)
        (let* ((name (cadr expr))
               (make (caaddr expr))
               (make-fields (cdaddr expr))
               (pred (cadddr expr))
               (fields (cddddr expr))
               (num-fields (length fields))
               (index (register-simple-type (symbol->string name) num-fields))
               (_define (rename 'define))
               (_lambda (rename 'lambda))
               (_let (rename 'let)))
          (define (index-of field ls)
            (let lp ((ls ls) (i 0))
              (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
          `(,(rename 'begin)
            (,_define ,pred (,(rename 'make-type-predicate)
                             ,(symbol->string pred)
                             ,index))
            ,@(let lp ((ls fields) (i 0) (res '()))
                (if (null? ls)
                    res
                    (let ((res
                           (cons `(,_define ,(cadar ls)
                                    (,(rename 'make-getter)
                                     ,(symbol->string (cadar ls))
                                     ,index
                                     ,i))
                                 res)))
                      (lp (cdr ls)
                          (+ i 1)
                          (if (pair? (cddar ls))
                              (cons
                               `(,_define ,(caddar ls)
                                  (,(rename 'make-setter)
                                   ,(symbol->string (caddar ls))
                                   ,index
                                   ,i))
                               res)
                              res)))))
            (,_define ,make
              ,(let lp ((ls make-fields) (sets '()) (set-defs '()))
                 (cond
                  ((null? ls)
                   `(,_let ((%make (,(rename 'make-constructor)
                                    ,(symbol->string make)
                                    ,index))
                            ,@set-defs)
                      (,_lambda ,make-fields
                        (,_let ((res (%make)))
                          ,@sets
                          res))))
                  (else
                   (let ((field (assq (car ls) fields)))
                     (cond
                      ((not field)
                       (error "unknown record field in constructor" (car ls)))
                      ((pair? (cddr field))
                       (lp (cdr ls)
                           (cons (list (caddr field) 'res (car ls)) sets)
                           set-defs))
                      (else
                       (let* ((setter-name
                               (string-append "%" (symbol->string name) "-"
                                              (symbol->string (car ls)) "-set!"))
                              (setter (rename (string->symbol setter-name)))
                              (i (index-of (car ls) fields)))
                         (lp (cdr ls)
                             (cons (list setter 'res (car ls)) sets)
                             (cons (list setter
                                         (list (rename 'make-setter)
                                               setter-name
                                               index
                                               (index-of (car ls) fields)))
                                   set-defs)))))))))))))))))