picrin/piclib/compile.scm

(begin

  ;; expand

  (define-values (make-identifier
                  identifier?
                  identifier=?
                  identifier-name
                  identifier-environment
                  make-environment
                  default-environment
                  environment?
                  find-identifier
                  add-identifier!
                  set-identifier!
                  macro-objects
                  expand)
    (let ()

      ;; identifier

      (define-record-type identifier
          (make-identifier name env)
          %identifier?
        (name identifier-name)
        (env identifier-environment))

      (define (identifier? obj)
        (or (symbol? obj) (%identifier? obj)))

      (define (identifier=? id1 id2)
        (cond
         ((and (symbol? id1) (symbol? id2))
          (eq? id1 id2))
         ((and (%identifier? id1) (%identifier? id2))
          (eq? (find-identifier (identifier-name id1) (identifier-environment id1))
               (find-identifier (identifier-name id2) (identifier-environment id2))))
         (else
          #f)))

      (set! equal?
            (let ((e? equal?))
              (lambda (x y)
                (if (%identifier? x)
                    (identifier=? x y)
                    (e? x y)))))


      ;; environment

      (define-record-type environment
          (%make-environment parent prefix binding)
          environment?
        (parent  environment-parent)
        (prefix  environment-prefix)
        (binding environment-binding))

      (define (search-scope id env)
        ((environment-binding env) id))

      (define (find-identifier id env)
        (or (search-scope id env)
            (let ((parent (environment-parent env)))
              (if parent
                  (find-identifier id parent)
                  (if (symbol? id)
                      (add-identifier! id env)
                      (find-identifier (identifier-name id)
                                       (identifier-environment id)))))))

      (define add-identifier!
        (let ((uniq
               (let ((n 0))
                 (lambda (id)
                   (let ((m n))
                     (set! n (+ n 1))
                     (string->symbol
                      (string-append
                       "."
                       (symbol->string
                        (let loop ((id id))
                          (if (symbol? id)
                              id
                              (loop (identifier-name id)))))
                       "."
                       (number->string m))))))))
          (lambda (id env)
            (or (search-scope id env)
                (if (and (not (environment-parent env)) (symbol? id))
                    (string->symbol
                     (string-append
                      (environment-prefix env)
                      (symbol->string id)))
                    (let ((uid (uniq id)))
                      (set-identifier! id uid env)
                      uid))))))

      (define (set-identifier! id uid env)
        ((environment-binding env) id uid))

      (define (make-environment prefix)
        (%make-environment #f (symbol->string prefix) (make-ephemeron-table)))

      (define default-environment
        (let ((env (make-environment (string->symbol ""))))
          (for-each
           (lambda (x) (set-identifier! x x env))
           '(core#define
             core#set!
             core#quote
             core#lambda
             core#if
             core#begin
             core#define-macro))
          env))

      (define (extend-environment parent)
        (%make-environment parent #f (make-ephemeron-table)))


      ;; macro

      (define global-macro-table
        (make-dictionary))

      (define (find-macro uid)
        (and (dictionary-has? global-macro-table uid)
             (dictionary-ref global-macro-table uid)))

      (define (add-macro! uid expander) ; TODO warn on redefinition
        (dictionary-set! global-macro-table uid expander))

      (define (shadow-macro! uid)
        (when (dictionary-has? global-macro-table uid)
          (dictionary-delete! global-macro-table uid)))

      (define (macro-objects)
        global-macro-table)


      ;; expander

      (define expand
        (let ((task-queue (make-parameter '())))

          (define (queue task)
            (let ((tmp (cons #f #f)))
              (task-queue `((,tmp . ,task) . ,(task-queue)))
              tmp))

          (define (run-all)
            (for-each
             (lambda (x)
               (let ((task (cdr x)) (skelton (car x)))
                 (let ((x (task)))
                   (set-car! skelton (car x))
                   (set-cdr! skelton (cdr x)))))
             (reverse (task-queue))))

          (define (caddr x) (car (cddr x)))

          (define (map* proc list*)
            (cond
             ((null? list*) list*)
             ((pair? list*) (cons (proc (car list*)) (map* proc (cdr list*))))
             (else (proc list*))))

          (define (literal? x)
            (not (or (identifier? x) (pair? x))))

          (define (call? x)
            (and (list? x)
                 (not (null? x))
                 (identifier? (car x))))

          (define (expand-variable var env)
            (let ((x (find-identifier var env)))
              (let ((m (find-macro x)))
                (if m
                    (expand-node (m var env) env)
                    x))))

          (define (expand-quote obj)
            `(core#quote ,obj))

          (define (expand-define var form env)
            (let ((uid (add-identifier! var env)))
              (shadow-macro! uid)
              `(core#define ,uid ,(expand-node form env))))

          (define (expand-lambda args body env)
            (let ((env (extend-environment env)))
              (let ((args (map* (lambda (var) (add-identifier! var env)) args)))
                (parameterize ((task-queue '()))
                  (let ((body (expand-node body env)))
                    (run-all)
                    `(core#lambda ,args ,body))))))

          (define (expand-define-macro var transformer env)
            (let ((uid (add-identifier! var env)))
              (let ((expander (load (compile (expand transformer env)))))
                (add-macro! uid expander)
                #undefined)))

          (define (expand-node expr env)
            (cond
             ((literal? expr) expr)
             ((identifier? expr) (expand-variable expr env))
             ((call? expr)
              (let ((functor (find-identifier (car expr) env)))
                (case functor
                  ((core#quote) (expand-quote (cadr expr)))
                  ((core#define) (expand-define (cadr expr) (caddr expr) env))
                  ((core#lambda) (queue (lambda () (expand-lambda (cadr expr) (caddr expr) env))))
                  ((core#define-macro) (expand-define-macro (cadr expr) (caddr expr) env))
                  (else
                   (let ((m (find-macro functor)))
                     (if m
                         (expand-node (m expr env) env)
                         (map (lambda (x) (expand-node x env)) expr)))))))
             ((list? expr)
              (map (lambda (x) (expand-node x env)) expr))
             (else
              (error "invalid expression" expr))))

          (define (expand expr env)
            (let ((x (expand-node expr env)))
              (run-all)
              x))

          expand))

      (values make-identifier
              identifier?
              identifier=?
              identifier-name
              identifier-environment
              make-environment
              default-environment
              environment?
              find-identifier
              add-identifier!
              set-identifier!
              macro-objects
              expand)))


  ;; built-in macros

  (let ()

    (define (define-transformer name transformer)
      (dictionary-set! (macro-objects) name transformer))

    (define (the var)
      (make-identifier var default-environment))

    (let
        ;; cache popular identifiers
        ((the-core-define (the 'core#define))
         (the-core-lambda (the 'core#lambda))
         (the-core-begin (the 'core#begin))
         (the-core-quote (the 'core#quote))
         (the-core-set! (the 'core#set!))
         (the-core-if (the 'core#if))
         (the-core-define-macro (the 'core#define-macro))
         (the-define (the 'define))
         (the-lambda (the 'lambda))
         (the-begin (the 'begin))
         (the-quote (the 'quote))
         (the-set! (the 'set!))
         (the-if (the 'if))
         (the-define-macro (the 'define-macro)))

      (define-transformer 'quote
        (lambda (form env)
          (if (= (length form) 2)
              (let ((obj (cadr form)))
                (cond
                 ((pair? obj) `(,(the 'cons) (,the-quote ,(car obj)) (,the-quote ,(cdr obj))))
                 ((vector? obj) `(,(the 'vector) . ,(vector->list
                                                     (vector-map (lambda (obj) `(,the-quote ,obj)) obj))))
                 (else `(,the-core-quote ,obj))))
              (error "malformed quote" form))))

      (define-transformer 'if
        (lambda (form env)
          (let ((len (length form)))
            (cond
             ((= len 3) `(,@form #undefined))
             ((= len 4) `(,the-core-if . ,(cdr form)))
             (else (error "malformed if" form))))))

      (define-transformer 'begin
        (lambda (form env)
          (let ((len (length form)))
            (cond
             ((= len 1) #undefined)
             ((= len 2) (cadr form))
             ((= len 3) `(,the-core-begin . ,(cdr form)))
             (else `(,the-core-begin ,(cadr form) (,the-begin . ,(cddr form))))))))

      (define-transformer 'set!
        (lambda (form env)
          (if (and (= (length form) 3) (identifier? (cadr form)))
              `(,the-core-set! . ,(cdr form))
              (error "malformed set!" form))))

      (define (check-formal formal)
        (or (null? formal)
            (identifier? formal)
            (and (pair? formal)
                 (identifier? (car formal))
                 (check-formal (cdr formal)))))

      (define-transformer 'lambda
        (lambda (form env)
          (if (= (length form) 1)
              (error "malformed lambda" form)
              (if (check-formal (cadr form))
                  `(,the-core-lambda ,(cadr form) (,the-begin . ,(cddr form)))
                  (error "malformed lambda" form)))))

      (define-transformer 'define
        (lambda (form env)
          (let ((len (length form)))
            (if (= len 1)
                (error "malformed define" form)
                (let ((formal (cadr form)))
                  (if (identifier? formal)
                      (if (= len 3)
                          `(,the-core-define . ,(cdr form))
                          (error "malformed define" form))
                      (if (pair? formal)
                          `(,the-define ,(car formal) (,the-lambda ,(cdr formal) . ,(cddr form)))
                          (error "define: binding to non-varaible object" form))))))))

      (define-transformer 'define-macro
        (lambda (form env)
          (if (= (length form) 3)
              (if (identifier? (cadr form))
                  `(,the-core-define-macro . ,(cdr form))
                  (error "define-macro: binding to non-variable object" form))
              (error "malformed define-macro" form))))


      (define-macro define-auxiliary-syntax
        (lambda (form _)
          `(define-transformer ',(cadr form)
             (lambda _
               (error "invalid use of auxiliary syntax" ',(cadr form))))))

      (define-auxiliary-syntax else)
      (define-auxiliary-syntax =>)
      (define-auxiliary-syntax unquote)
      (define-auxiliary-syntax unquote-splicing)

      (define-transformer 'let
        (lambda (form env)
          (if (identifier? (cadr form))
              (let ((name   (car (cdr form)))
                    (formal (car (cdr (cdr form))))
                    (body   (cdr (cdr (cdr form)))))
                `((,the-lambda ()
                               (,the-define (,name . ,(map car formal)) . ,body)
                               (,name . ,(map cadr formal)))))
              (let ((formal (car (cdr form)))
                    (body   (cdr (cdr form))))
                `((,the-lambda ,(map car formal) . ,body) . ,(map cadr formal))))))

      (define-transformer 'and
        (lambda (form env)
          (if (null? (cdr form))
              #t
              (if (null? (cddr form))
                  (cadr form)
                  `(,the-if ,(cadr form) (,(the 'and) . ,(cddr form)) #f)))))

      (define-transformer 'or
        (lambda (form env)
          (if (null? (cdr form))
              #f
              (let ((tmp (make-identifier 'it env))) ; should we use #f as the env for tmp?
                `(,(the 'let) ((,tmp ,(cadr form)))
                  (,the-if ,tmp ,tmp (,(the 'or) . ,(cddr form))))))))

      (define-transformer 'cond
        (lambda (form env)
          (let ((clauses (cdr form)))
            (if (null? clauses)
                #undefined
                (let ((clause (car clauses)))
                  (if (and (identifier? (car clause))
                           (identifier=? (the 'else) (make-identifier (car clause) env)))
                      `(,the-begin . ,(cdr clause))
                      (if (null? (cdr clause))
                          `(,(the 'or) ,(car clause) (,(the 'cond) . ,(cdr clauses)))
                          (if (and (identifier? (cadr clause))
                                   (identifier=? (the '=>) (make-identifier (cadr clause) env)))
                              (let ((tmp (make-identifier 'tmp env)))
                                `(,(the 'let) ((,tmp ,(car clause)))
                                  (,the-if ,tmp (,(cadr (cdr clause)) ,tmp) (,(the 'cond) . ,(cddr form)))))
                              `(,the-if ,(car clause)
                                        (,the-begin . ,(cdr clause))
                                        (,(the 'cond) . ,(cdr clauses)))))))))))

      (define-transformer 'quasiquote
        (lambda (form env)

          (define (quasiquote? form)
            (and (pair? form)
                 (identifier? (car form))
                 (identifier=? (the 'quasiquote) (make-identifier (car form) env))))

          (define (unquote? form)
            (and (pair? form)
                 (identifier? (car form))
                 (identifier=? (the 'unquote) (make-identifier (car form) env))))

          (define (unquote-splicing? form)
            (and (pair? form)
                 (pair? (car form))
                 (identifier? (caar form))
                 (identifier=? (the 'unquote-splicing) (make-identifier (caar form) env))))

          (define (qq depth expr)
            (cond
             ;; unquote
             ((unquote? expr)
              (if (= depth 1)
                  (cadr expr)
                  (list (the 'list)
                        (list (the 'quote) (the 'unquote))
                        (qq (- depth 1) (car (cdr expr))))))
             ;; unquote-splicing
             ((unquote-splicing? expr)
              (if (= depth 1)
                  (list (the 'append)
                        (car (cdr (car expr)))
                        (qq depth (cdr expr)))
                  (list (the 'cons)
                        (list (the 'list)
                              (list (the 'quote) (the 'unquote-splicing))
                              (qq (- depth 1) (car (cdr (car expr)))))
                        (qq depth (cdr expr)))))
             ;; quasiquote
             ((quasiquote? expr)
              (list (the 'list)
                    (list (the 'quote) (the 'quasiquote))
                    (qq (+ depth 1) (car (cdr expr)))))
             ;; list
             ((pair? expr)
              (list (the 'cons)
                    (qq depth (car expr))
                    (qq depth (cdr expr))))
             ;; vector
             ((vector? expr)
              (list (the 'list->vector) (qq depth (vector->list expr))))
             ;; simple datum
             (else
              (list (the 'quote) expr))))

          (let ((x (cadr form)))
            (qq 1 x))))

      (define-transformer 'let*
        (lambda (form env)
          (let ((bindings (car (cdr form)))
                (body     (cdr (cdr form))))
            (if (null? bindings)
                `(,(the 'let) () . ,body)
                `(,(the 'let) ((,(car (car bindings)) . ,(cdr (car bindings))))
                  (,(the 'let*) ,(cdr bindings) . ,body))))))

      (define-transformer 'letrec
        (lambda (form env)
          `(,(the 'letrec*) . ,(cdr form))))

      (define-transformer 'letrec*
        (lambda (form env)
          (let ((bindings (car (cdr form)))
                (body     (cdr (cdr form))))
            (let ((variables (map (lambda (v) `(,v #undefined)) (map car bindings)))
                  (initials  (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))
              `(,(the 'let) ,variables
                ,@initials
                ,@body)))))

      (define-transformer 'let-values
        (lambda (form env)
          `(,(the 'let*-values) ,@(cdr form))))

      (define-transformer 'let*-values
        (lambda (form env)
          (let ((formals (cadr form))
                (body    (cddr form)))
            (if (null? formals)
                `(,(the 'let) () ,@body)
                (let ((formal (car formals)))
                  `(,(the 'call-with-values) (,the-lambda () . ,(cdr formal))
                    (,(the 'lambda) ,(car formal)
                     (,(the 'let*-values) ,(cdr formals) . ,body))))))))

      (define-transformer 'define-values
        (lambda (form env)
          (let ((formal (cadr form))
                (body   (cddr form)))
            (let ((tmps (let loop ((formal formal))
                          (if (identifier? formal)
                              (make-identifier formal env)
                              (if (pair? formal)
                                  (cons (make-identifier (car formal) env) (loop (cdr formal)))
                                  '())))))
              `(,the-begin
                ,@(let loop ((formal formal))
                    (if (identifier? formal)
                        `((,the-define ,formal #undefined))
                        (if (pair? formal)
                            (cons `(,the-define ,(car formal) #undefined) (loop (cdr formal)))
                            '())))
                (,(the 'call-with-values) (,the-lambda () . ,body)
                 (,the-lambda ,tmps . ,(let loop ((formal formal) (tmps tmps))
                                         (if (identifier? formal)
                                             `((,the-set! ,formal ,tmps))
                                             (if (pair? formal)
                                                 (cons `(,the-set! ,(car formal) ,(car tmps))
                                                       (loop (cdr formal) (cdr tmps)))
                                                 '()))))))))))

      (define-transformer 'do
        (lambda (form env)
          (let ((bindings (car (cdr form)))
                (test     (car (car (cdr (cdr form)))))
                (cleanup  (cdr (car (cdr (cdr form)))))
                (body     (cdr (cdr (cdr form)))))
            (let ((loop (make-identifier 'loop env)))
              `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)
                (,the-if ,test
                         (,the-begin . ,cleanup)
                         (,the-begin
                          ,@body
                          (,loop . ,(map (lambda (x)
                                           (if (null? (cdr (cdr x)))
                                               (car x)
                                               (car (cdr (cdr x)))))
                                         bindings)))))))))

      (define-transformer 'when
        (lambda (form env)
          (let ((test (car (cdr form)))
                (body (cdr (cdr form))))
            `(,the-if ,test
                      (,the-begin ,@body)
                      #undefined))))

      (define-transformer 'unless
        (lambda (form env)
          (let ((test (car (cdr form)))
                (body (cdr (cdr form))))
            `(,the-if ,test
                      #undefined
                      (,the-begin ,@body)))))

      (define-transformer 'case
        (lambda (form env)
          (let ((key     (car (cdr form)))
                (clauses (cdr (cdr form))))
            (let ((the-key (make-identifier 'key env)))
              `(,(the 'let) ((,the-key ,key))
                ,(let loop ((clauses clauses))
                   (if (null? clauses)
                       #undefined
                       (let ((clause (car clauses)))
                         `(,the-if ,(if (and (identifier? (car clause))
                                             (identifier=? (the 'else) (make-identifier (car clause) env)))
                                        #t
                                        `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))
                                   ,(if (and (identifier? (cadr clause))
                                             (identifier=? (the '=>) (make-identifier (cadr clause) env)))
                                        `(,(car (cdr (cdr clause))) ,the-key)
                                        `(,the-begin ,@(cdr clause)))
                                   ,(loop (cdr clauses)))))))))))

      (define-transformer 'parameterize
        (lambda (form env)
          (let ((formal (car (cdr form)))
                (body   (cdr (cdr form))))
            `(,(the 'with-dynamic-environment)
              (,(the 'list) ,@(map (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))
              (,the-lambda () ,@body)))))

      (define-transformer 'define-record-type
        (lambda (form env)
          (let ((type (car (cdr form)))
                (ctor (car (cdr (cdr form))))
                (pred (car (cdr (cdr (cdr form)))))
                (fields (cdr (cdr (cdr (cdr form))))))
            `(,the-begin
              (,the-define ,ctor
                           (,(the 'make-record) ',type
                            (,(the 'vector) . ,(map (lambda (field) (if (memq (car field) (cdr ctor)) (car field) #undefined)) fields))))
              (,the-define ,pred
                           (,(the 'lambda) (obj)
                            (,(the 'and) (,(the 'record?) obj) (,(the 'eq?) (,(the 'record-type) obj) ',type))))
              . ,(let loop ((fields fields) (pos 0) (acc '()))
                   (if (null? fields)
                       acc
                       (let ((field (car fields)))
                         (let ((defs `((,the-define (,(cadr field) obj)
                                                    (,the-if (,pred obj)
                                                             (,(the 'vector-ref) (,(the 'record-datum) obj) ,pos)
                                                             (,(the 'error) "record type mismatch" obj ',type)))
                                       . ,(if (null? (cddr field))
                                              '()
                                              `((,the-define (,(car (cddr field)) obj value)
                                                             (,the-if (,pred obj)
                                                                      (,(the 'vector-set!) (,(the 'record-datum) obj) ,pos value)
                                                                      (,(the 'error) "record type mismatch" obj ',type))))))))
                           (loop (cdr fields) (+ pos 1) `(,@defs . ,acc))))))))))))

  ;; compile

  (define-values (compile)
    (let ()

      (define (caddr x) (car (cddr x)))
      (define (cadddr x) (cadr (cddr x)))
      (define (max a b) (if (< a b) b a))
      (define (integer? n) (and (number? n) (exact? n)))

      (define normalize
        (let ((defs (make-parameter '())))

          ;; 1. remove core# prefix from keywords
          ;; 2. eliminates internal definitions by replacing with equivalent let & set!
          ;; 3. transform a var into (ref var)
          ;; 4. wrap raw constants with quote

          ;; TODO: warn redefinition, warn duplicate variables

          (define (normalize e)
            (cond
             ((symbol? e) `(ref ,e))
             ((not (pair? e)) `(quote ,e))
             (else
              (case (car e)
                ((core#quote) `(quote . ,(cdr e)))
                ((core#define)
                 (let ((var (cadr e)) (val (caddr e)))
                   (defs (cons var (defs)))
                   `(set! ,var ,(normalize val))))
                ((core#lambda)
                 (let ((args (cadr e)) (body (caddr e)))
                   (parameterize ((defs '()))
                     (let ((body (normalize body)))
                       (if (null? (defs))
                           `(lambda ,args ,body)
                           `(lambda ,args
                              ((lambda ,(defs) ,body) ,@(map (lambda (_) ''#f) (defs)))))))))
                ((core#set!) `(set! ,(cadr e) ,(normalize (caddr e))))
                ((core#if) `(if . ,(map normalize (cdr e))))
                ((core#begin) `(begin . ,(map normalize (cdr e))))
                (else
                 (map normalize e))))))

          normalize))


      (define transform
        (let ()

          ;; tail-conscious higher-order CPS transformation

          ;; target language
          ;; E ::= A
          ;;     | (if A E E)
          ;;     | (set! v A E)
          ;;     | (A A ...)
          ;; A ::= (lambda (var ...) E)
          ;;     | (ref v)
          ;;     | (quote x)
          ;;     | (undefined)

          (define uniq
            (let ((n 0))
              (lambda ()
                (set! n (+ n 1))
                (string->symbol
                 (string-append "$" (number->string n))))))

          (define (transform-k e k)
            (case (car e)
              ((ref lambda quote) (k (transform-v e)))
              ((begin) (transform-k (cadr e)
                                    (lambda (_)
                                      (transform-k (caddr e) k))))
              ((set!) (transform-k (caddr e)
                                   (lambda (v)
                                     `(set! ,(cadr e) ,v ,(k '(undefined))))))
              ((if) (let ((v (uniq))
                          (c (uniq)))
                      `((lambda (,c)
                          ,(transform-k (cadr e)
                                        (lambda (x)
                                          `(if ,x
                                               ,(transform-c (caddr e) `(ref ,c))
                                               ,(transform-c (cadddr e) `(ref ,c))))))
                        (lambda (,v) ,(k `(ref ,v))))))
              (else
               (let* ((v (uniq))
                      (c `(lambda (,v) ,(k `(ref ,v)))))
                 (transform-k (car e)
                              (lambda (f)
                                (transform*-k (cdr e)
                                              (lambda (args)
                                                `(,f ,c ,@args)))))))))

          (define (transform*-k es k)
            (if (null? es)
                (k '())
                (transform-k (car es)
                             (lambda (x)
                               (transform*-k (cdr es)
                                             (lambda (xs)
                                               (k (cons x xs))))))))

          (define (transform-c e c)
            (case (car e)
              ((ref lambda quote) `(,c ,(transform-v e)))
              ((begin) (transform-k (cadr e)
                                    (lambda (_)
                                      (transform-c (caddr e) c))))
              ((set!) (transform-k (caddr e)
                                   (lambda (v)
                                     `(set! ,(cadr e) ,v (,c (undefined))))))
              ((if) (if (and (pair? c) (eq? 'lambda (car c)))
                        (let ((k (uniq)))
                          `((lambda (,k)
                              ,(transform-k (cadr e)
                                            (lambda (x)
                                              `(if ,x
                                                   ,(transform-c (caddr e) `(ref ,k))
                                                   ,(transform-c (cadddr e) `(ref ,k))))))
                            ,c))
                        (transform-k (cadr e)
                                     (lambda (x)
                                       `(if ,x
                                            ,(transform-c (caddr e) c)
                                            ,(transform-c (cadddr e) c))))))
              (else
               (transform-k (car e)
                            (lambda (f)
                              (transform*-k (cdr e)
                                            (lambda (args)
                                              `(,f ,c ,@args))))))))

          (define (transform-v e)
            (case (car e)
              ((ref quote) e)
              ((lambda)
               (let ((k (uniq)))
                 `(lambda (,k . ,(cadr e)) ,(transform-c (caddr e) `(ref ,k)))))))

          (lambda (e)
            (let ((k (uniq)))
              `(lambda (,k) ,(transform-c e `(ref ,k)))))))


      (define codegen
        (let ()

          ;; TODO: check range of index/depth/frame_size/irepc/objc

          (define (lookup var env)
            (let up ((depth 0) (env env))
              (if (null? env)
                  `(global ,var)
                  (let loop ((index 1) (binding (car env)))
                    (if (symbol? binding)
                        (if (eq? var binding)
                            `(local ,depth ,index)
                            (up (+ depth 1) (cdr env)))
                        (if (null? binding)
                            (up (+ depth 1) (cdr env))
                            (if (eq? var (car binding))
                                `(local ,depth ,index)
                                (loop (+ index 1) (cdr binding)))))))))

          (define env (make-parameter '()))
          (define code (make-parameter '()))
          (define reps (make-parameter '()))
          (define objs (make-parameter '()))

          (define (emit inst)
            (code (cons inst (code))))

          (define (emit-irep irep)
            (let ((n (length (reps))))
              (reps (cons irep (reps)))
              n))

          (define (emit-obj obj)       ; TODO remove duplicates
            (let ((n (length (objs))))
              (objs (cons obj (objs)))
              n))

          (define make-label
            (let ((n 0))
              (lambda ()
                (let ((m n))
                  (set! n (+ n 1))
                  m))))

          (define (emit-label label)
            (code (cons label (code))))

          (define (codegen-e e)
            (case (car e)
              ((ref lambda quote undefined) (codegen-a e 0))
              ((set!) (begin
                        (codegen-a (caddr e) 0)
                        (let ((x (lookup (cadr e) (env))))
                          (if (eq? 'global (car x))
                              (let ((i (emit-obj (cadr x))))
                                (emit `(GSET 0 ,i)))
                              (emit `(LSET 0 . ,(cdr x)))))
                        (codegen-e (cadddr e))))
              ((if) (begin
                      (codegen-a (cadr e) 0)
                      (let ((label (make-label)))
                        (emit `(COND 0 ,label))
                        (codegen-e (caddr e))
                        (emit-label label)
                        (codegen-e (cadddr e)))))
              (else (begin
                      (let loop ((i 0) (e e))
                        (unless (null? e)
                          (codegen-a (car e) i)
                          (loop (+ i 1) (cdr e))))
                      (emit `(CALL ,(- (length e) 1)))))))

          (define (codegen-a e i)
            (case (car e)
              ((ref) (let ((x (lookup (cadr e) (env))))
                       (if (eq? 'global (car x))
                           (let ((n (emit-obj (cadr x))))
                             (emit `(GREF ,i ,n)))
                           (emit `(LREF ,i . ,(cdr x))))))
              ((quote) (let ((obj (cadr e)))
                         (cond ((eq? #t obj) (emit `(LOADT ,i)))
                               ((eq? #f obj) (emit `(LOADF ,i)))
                               ((null? obj) (emit `(LOADN ,i)))
                               ((eq? #undefined obj) (emit `(LOADU ,i)))
                               ((and (integer? obj) (<= -127 obj 127)) (emit `(LOADI ,i ,obj)))
                               (else (let ((n (emit-obj obj)))
                                       (emit `(LOAD ,i ,n)))))))
              ((undefined) (emit `(LOADU ,i)))
              ((lambda) (let ((frame-size
                               (let loop ((e (caddr e)))
                                 (case (car e)
                                   ((ref lambda quote undefined) 1)
                                   ((if) (max (loop (caddr e)) (loop (cadddr e))))
                                   ((set!) (loop (cadddr e)))
                                   (else (+ 1 (length e))))))
                              (argc-varg
                               (let loop ((args (cadr e)) (c 0))
                                 (if (symbol? args)
                                     (cons c #t)
                                     (if (null? args)
                                         (cons c #f)
                                         (loop (cdr args) (+ 1 c)))))))
                          (let ((irep
                                 (parameterize ((code '())
                                                (env (cons (cadr e) (env)))
                                                (reps '())
                                                (objs '()))
                                   (codegen-e (caddr e))
                                   (list (reverse (code)) (reverse (reps)) (reverse (objs)) argc-varg frame-size))))
                            (let ((n (emit-irep irep)))
                              (emit `(PROC ,i ,n))))))))

          (lambda (e)
            (parameterize ((code '()) (env '()) (reps '()) (objs '()))
              (codegen-e e)
              (car (reps))))))

      (lambda (e)
        (codegen (transform (normalize e))))))


  ;; eval

  (define (eval expr . env)
    (load (compile (expand expr (if (null? env) default-environment (car env)))))))