(define-module (srfi 9)
  (export define-record-type)
  (import-immutable (scheme))
  (body
   (define-syntax define-record-type
     (er-macro-transformer
      (lambda (expr rename compare)
        (let* ((name (cadr expr))
               (name-str (symbol->string (identifier->symbol name)))
               (make (caaddr expr))
               (make-fields (cdaddr expr))
               (pred (cadddr expr))
               (fields (cddddr expr))
               (num-fields (length fields))
               (_define (rename 'define))
               (_lambda (rename 'lambda))
               (_let (rename 'let))
               (_register (rename 'register-simple-type)))
          (define (index-of field ls)
            (let lp ((ls ls) (i 0))
              (if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
          `(,(rename 'begin)
            ;; type
            (,_define ,name (,_register ,name-str ,num-fields))
            ;; predicate
            (,_define ,pred (,(rename 'make-type-predicate)
                             ,(symbol->string (identifier->symbol pred))
                             ,name))
            ;; fields
            ,@(let lp ((ls fields) (i 0) (res '()))
                (if (null? ls)
                    res
                    (let ((res
                           (cons `(,_define ,(cadar ls)
                                    (,(rename 'make-getter)
                                     ,(symbol->string
                                       (identifier->symbol (cadar ls)))
                                     ,name
                                     ,i))
                                 res)))
                      (lp (cdr ls)
                          (+ i 1)
                          (if (pair? (cddar ls))
                              (cons
                               `(,_define ,(caddar ls)
                                  (,(rename 'make-setter)
                                   ,(symbol->string
                                     (identifier->symbol (caddar ls)))
                                   ,name
                                   ,i))
                               res)
                              res)))))
            ;; constructor
            (,_define ,make
              ,(let lp ((ls make-fields) (sets '()) (set-defs '()))
                 (cond
                  ((null? ls)
                   `(,_let ((%make (,(rename 'make-constructor)
                                    ,(symbol->string (identifier->symbol make))
                                    ,name))
                            ,@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 "%" name-str "-"
                                              (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
                                               name
                                               (index-of (car ls) fields)))
                                   set-defs)))))))))))))))))