diff --git a/compiler.ss b/compiler.ss
new file mode 100755
index 0000000..6305bde
--- /dev/null
+++ b/compiler.ss
@@ -0,0 +1,296 @@
+#! /usr/bin/mzscheme
+#lang scheme
+
+(define (simplify-form form)
+  (if (pair? form)
+    (case (car form)
+      [(let) (simplify-let form)]
+      [(let*) (simplify-let* form)]
+      [(letrec) (simplify-letrec form)]
+      [(if) (simplify-if form)]
+      [(lambda) (simplify-lambda form)]
+      [(begin) `(%bind () ,@(map simplify-form (cdr form)))]
+      [(set!) (simplify-set! form)]
+      [(car cdr cons) (simplify-primitive (case (first form)
+                                             [(car)  '%car]
+                                             [(cdr)  '%cdr]
+                                             [(cons) '%cons])
+                                          (cdr form))]
+      [(%bind %if %tail-call %apply %lambda %set! %cons %car %cdr) form]
+      [else (simplify-funcall form)])
+    form))
+
+(define (simplify-set! form)
+  (let ([value-form (simplify-form (third form))])
+    (if (and (pair? value-form) (eq? (first value-form) '%bind))
+        `(%bind ,(second value-form)
+           ,@(foldr (lambda (x s)
+                      (if (pair? s)
+                          (cons x s)
+                          (list (simplify-set! `(set! ,(second form) ,x)))))
+                    '()
+                    (cddr value-form)))
+        `(%set! ,(second form) ,value-form))))
+
+(define (simplify-primitive new-id value-forms)
+  (define bindings (map (lambda (vf)
+                          (if (pair? vf)
+                              (list (gensym) vf)
+                              (list vf vf)))
+                        value-forms))
+  (define temp-bindings (filter (lambda (x) (not (eq? (first x) (second x))))
+                                bindings))
+
+  `(%bind ,(map first temp-bindings)
+     ,@(map (lambda (x) (simplify-set! `(set! ,(first x) ,(second x)))) temp-bindings)
+     (,new-id ,@(map first bindings))))
+
+; (let ([var expr]...) bodyexpr...)  ; first eval exprs, then assign bindings in parallel
+;    => (%bind (tmp...)
+;         (%set! tmp ,(simplify-form expr))...
+;         (%bind (var...)
+;           (%set! var tmp)...
+;           bodyexpr...))
+
+(define (simplify-let form)
+   (define bindings (second form))
+   (define bodyexprs (cdr (cdr form)))
+   (define vars (map (lambda (x) (if (pair? x) (first x) x)) bindings))
+   (define temp-bindings
+     (append-map
+       (lambda (x) (if (pair? x)
+                       (let ([tmp (gensym)])
+                         `((,tmp
+                            ,(simplify-form `(set! ,tmp ,(second x)))
+                            (%set! ,(first x) ,tmp))))
+                         '()))
+       bindings))
+   (if (pair? bindings)
+       (if (pair? (cdr bindings))
+           `(%bind ,(map first temp-bindings)
+              ,@(map second temp-bindings)
+              (%bind ,vars
+                ,@(map third temp-bindings)
+                ,@(map simplify-form bodyexprs)))
+           `(%bind (,(first vars))
+              ,@(if (pair? (first bindings))
+                  `(,(simplify-form `(set! ,(first vars) ,(second (first bindings)))))
+                  '())
+              ,@(map simplify-form bodyexprs)))
+       `(%bind () ,@bodyexprs)))
+
+; (let* ...)   ; eval exprs & bind variables serially
+;    => (let ([var-0 expr-0])
+;         (let ([var-1 expr-1])
+;           (...
+;             bodyexprs...)))
+
+(define (simplify-let* form)
+   (define bindings (second form))
+   (define bodyexprs (cdr (cdr form)))
+   (define (add-binding bind bodyexpr)
+      `(let (,bind) ,bodyexpr))
+   (simplify-form (foldr add-binding `(begin ,@bodyexprs) bindings)))
+
+; (letrec ...) ; init bindings to undefined, then assign values in series
+;    => (let (var...)
+;         (set! var expr)...
+;         bodyexprs)
+
+(define (simplify-letrec form)
+  (define bindings (second form))
+  (define bodyexprs (cdr (cdr form)))
+  (simplify-form
+  `(%bind (,@(map (lambda (x) (if (pair? x) (first x) x)) bindings))
+     ,@(append-map
+         (lambda (x)
+           (if (pair? x)
+               `((set! ,(first x) ,(simplify-form (second x))))
+               '()))
+         bindings)
+     ,@(map simplify-form bodyexprs))))
+
+(define (simplify-if form)
+  (define cond-val (gensym))
+  (define next-fn (gensym))
+  (define true-fn (gensym))
+  (define false-fn (gensym))
+  (define-values (cond-expr true-expr false-expr)
+                 (apply values (cdr form)))
+  (simplify-form
+    `(let ([,cond-val ,cond-expr]
+           [,true-fn  (lambda () ,true-expr)]
+           [,false-fn (lambda () ,false-expr)])
+       (let ([,next-fn (%if ,cond-val ,true-fn ,false-fn)])
+         (%apply ,next-fn %nil)))))
+
+; (lambda (required... [optional default-expr]... . rest) bodyexpr...)
+;    => (lambda argv
+;         (let ([argv-temp argv])
+;           (let ([required-0 (car argv-temp)])
+;             (set! argv-temp (cdr argv-temp)))
+;             (let ([required-1 (car argv-temp)])
+;               (set! argv-temp (cdr argv-temp)))
+;               (...
+;                 (let (optional-0)
+;                   (if (eq? argv-temp %nil)
+;                       (set! optional-0 default-expr-0)
+;                       (set! optional-0 (car argv-temp)))
+;                   (set! argv-temp (cdr argv-temp))
+;                   (let (optional-1)
+;                     (if (eq? argv-temp %nil)
+;                         (set! optional-1 default-expr-1)
+;                         (set! optional-1 (car argv-temp)))
+;                     (set! argv-temp (cdr argv-temp))
+;                     (...
+;                       (let ([rest argv-temp])
+;                         bodyexpr...)...)))...)))
+
+(define (simplify-lambda form)
+   (define arglist (car (cdr form)))
+   (define bodyexprs (cdr (cdr form)))
+   (define (split-arglist arglist)
+      (define (split-optional arglist)
+         (if (pair? arglist)
+             (let-values ([(opt rst) (split-optional (cdr arglist))])
+               (values (cons (car arglist) opt) rst)) 
+             (values '() arglist)))
+      (if (pair? arglist)
+          (if (pair? (car arglist))
+            (let-values ([(opt rst) (split-optional arglist)])
+               (values '() opt rst))
+            (let-values ([(req opt rst) (split-arglist (cdr arglist))])
+               (values (cons (car arglist) req) opt rst)))
+          (values '() '() #f)))
+
+   (define-values (requireds optionals rest) (split-arglist arglist))
+   (define argv-temp (gensym))
+   (define k (gensym))
+   (define rval (gensym))
+
+   (define (add-req req inner) `(let ([,req (car ,argv-temp)])
+                                  (set! ,argv-temp (cdr ,argv-temp))
+                                  ,inner))
+   (define (add-opt opt-list inner) `(let (,(car opt-list))
+                                       (if (pair? ,argv-temp)
+                                           (begin
+                                             (set! ,(first opt-list) (car ,argv-temp))
+                                             (set! ,argv-temp (cdr ,argv-temp)))
+                                           (set! ,(first opt-list) ,(second opt-list)))
+                                       ,inner))
+   (define rest+bodyexprs (if rest `(let ([,rest ,argv-temp]) ,@bodyexprs)
+                                   `(begin ,@bodyexprs)))
+   (define (add-tail-call k rval bind)
+     `(%bind ,(second bind)
+        ,@(foldr (lambda (subform after)
+                   (if (pair? after)
+                       (cons subform after)
+                       (if (and (pair? subform)
+                                (eq? (first subform) '%set!)
+                                (eq? (second subform) rval)
+                                (pair? (third subform))
+                                (eq? (first (third subform)) '%apply))
+                           (let ([fn (second (third subform))]
+                                 [argv (third (third subform))])
+                             `((%tail-call ,fn ,argv ,k)))
+                           `((%set! ,rval (%cons ,rval %nil))
+                             (%tail-call ,k ,rval #f)))))
+                  '()
+                  (cddr bind))))
+   `(%lambda 
+      ,(add-tail-call k rval
+         (flatten-binds
+           `(%bind (,rval ,k)
+              (%set! ,k %k)
+              ,(make-bindings-unique
+                 (simplify-form
+                   `(set! ,rval (let ([,argv-temp %argv])
+                                  ,(foldr add-req
+                                          (foldr add-opt
+                                                 rest+bodyexprs
+                                                 optionals)
+                                          requireds))))))))))
+
+; (fn-expr arg-expr...)
+;    => (let ([fn-var fn-expr] arg-var... argv)
+;         (set! fn-var fn-expr)
+;         (set! arg-var arg-expr)...
+;         (set! argv %nil)
+;         (set! argv (cons arg-var argv))... [reversed]
+;         (%apply fn-var argv))
+
+(define (simplify-funcall form)
+  (define fn-expr (car form))
+  (define arg-exprs (cdr form))
+  (define fn-var (gensym))
+  (define arg-vars (map (lambda (x) (gensym)) arg-exprs))
+  (define argv (gensym))
+  (simplify-form
+    `(%bind (,fn-var ,@arg-vars ,argv)
+       ,(simplify-form `(set! ,fn-var ,fn-expr))
+       ,@(map (lambda (x y) (simplify-form `(set! ,x ,y))) arg-vars arg-exprs)
+       (%set! ,argv %nil)
+       ,@(reverse (map (lambda (x) `(%set! ,argv (%cons ,x ,argv))) arg-vars))
+       (%apply ,fn-var ,argv))))
+
+(define (subst-var old-var new-var form)
+  (define (recurse form)
+    (subst-var old-var new-var form))
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (if (memq old-var (second form))
+           form
+           `(%bind ,(second form) ,@(map recurse (cddr form))))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr)
+       `(,(first form) ,@(map recurse (cdr form)))]
+      [else (error "Unsimplified form:" form)])
+    (if (eq? form old-var)
+        new-var
+        form)))
+
+(define (make-bindings-unique form)
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (let ([new-vars (map (lambda _ (gensym)) (second form))])
+         `(%bind ,new-vars
+            ,@(map (lambda (frm)
+                     (foldl (lambda (pair s)
+                              (subst-var (car pair)
+                                         (cdr pair)
+                                         s))
+                            (make-bindings-unique frm)
+                            (map cons (second form) new-vars)))
+                   (cddr form))))]
+      [(%if %tail-call %apply %lambda %set! %cons %car %cdr) form]
+      [else (error "Unsimplified form:" form)])
+    form))
+
+(define (flatten-binds form)
+  ;(pretty-print form) (write-char #\Newline)
+  (if (pair? form)
+    (case (car form)
+      [(%bind)
+       (let* ([bound-vars (second form)]
+              [subforms (append-map (lambda (form)
+                                      (let ([new-form (flatten-binds form)])
+                                        (if (and (pair? new-form) (eq? (car new-form) '%bind))
+                                          (begin
+                                            (set! bound-vars (append bound-vars (second new-form)))
+                                            (cddr new-form))
+                                          (list new-form))))
+                                    (cddr form))])
+         `(%bind ,bound-vars ,@subforms))]
+      [(%if %tail-call %apply %set! %lambda %cons %car %cdr) form]
+      [else (error "Unsimplified form:" form)])
+    form))
+
+(define (compile form)
+  (flatten-binds
+      (make-bindings-unique
+        (simplify-form `(lambda () ,form)))))
+
+(pretty-print (compile (read)))
+
+; vim:set sw=2 expandtab: