ruby-wisp-source 0.7.0

data/vendor/src/compiler.wisp

@@ -0,0 +1,1191 @@
+(ns wisp.compiler
+  "wisp language compiler"
+  (:use [wisp.reader :only [read-from-string]]
+        [wisp.ast :only [meta with-meta symbol? symbol keyword? keyword
+                         namespace unquote? unquote-splicing? quote?
+                         syntax-quote? name gensym pr-str]]
+        [wisp.sequence :only [empty? count list? list first second third
+                              rest cons conj reverse reduce vec last repeat
+                              map filter take concat]]
+        [wisp.runtime :only [odd? dictionary? dictionary merge keys vals
+                             contains-vector? map-dictionary string? number?
+                             vector? boolean? subs re-find true? false? nil?
+                             re-pattern? inc dec str char int = ==]]
+        [wisp.string :only [split join upper-case replace]]
+        [wisp.backend.javascript.writer :only [write-reference
+                                               write-keyword-reference
+                                               write-keyword write-symbol
+                                               write-nil write-comment
+                                               write-number write-string
+                                               write-number write-boolean]]))
+
+(defn ^boolean self-evaluating?
+  "Returns true if form is self evaluating"
+  [form]
+  (or (number? form)
+      (and (string? form)
+           (not (symbol? form))
+           (not (keyword? form)))
+      (boolean? form)
+      (nil? form)
+      (re-pattern? form)))
+
+
+;; Macros
+
+(def **macros** {})
+
+(defn execute-macro
+  "Applies macro registered with given `name` to a given `form`"
+  [name form]
+  (apply (get **macros** name)
+         (vec form)))
+
+(defn install-macro
+  "Registers given `macro` with a given `name`"
+  [name macro-fn]
+  (set! (get **macros** name) macro-fn))
+
+(defn macro?
+  "Returns true if macro with a given name is registered"
+  [name]
+  (and (symbol? name)
+       (get **macros** name)
+       true))
+
+
+(defn make-macro
+  "Makes macro"
+  [pattern body]
+  (let [macro-fn `(fn ~pattern ~@body)]
+        ;; compile the macro into native code and use the host's native
+        ;; eval to eval it into a function.
+        (eval (str "(" (compile (macroexpand macro-fn)) ")"))))
+
+
+(install-macro
+ 'defmacro
+ (fn
+  "Like defn, but the resulting function name is declared as a
+  macro and will be used as a macro by the compiler when it is
+  called."
+  [name signature & body]
+  (install-macro name (make-macro signature body))))
+
+
+;; special forms
+;;
+;; special forms are like macros for generating source code. It allows the
+;; generator to customize how certain forms look in the final output.
+;; these could have been macros that expand into basic forms, but we
+;; want readable output. Special forms are responsible for integrity
+;; checking of the form.
+
+(def **specials** {})
+
+(defn install-special
+  "Installs special function"
+  [name f validator]
+  (set! (get **specials** name)
+        (fn [form]
+          (if validator (validator form))
+          (f (with-meta (rest form) (meta form))))))
+
+(defn special?
+  "Returns true if special form"
+  [name]
+  (and (symbol? name)
+       (get **specials** name)
+       true))
+
+(defn execute-special
+  "Expands special form"
+  [name form]
+  ((get **specials** name) form))
+
+
+(defn opt [argument fallback]
+  (if (or (nil? argument) (empty? argument)) fallback (first argument)))
+
+(defn apply-form
+  "Take a form that has a list of children and make a form that
+  applies the children to the function `fn-name`"
+  [fn-name form quoted?]
+  (cons fn-name
+        (if quoted?
+            (map (fn [e] (list 'quote e)) form) form)
+            form))
+
+(defn apply-unquoted-form
+  "Same as apply-form, but respect unquoting"
+  [fn-name form]
+  (cons fn-name ;; ast.prepend ???
+        (map
+          (fn [e]
+              (if (unquote? e)
+                  (second e)
+                  (if (and (list? e)
+                           (keyword? (first e)))
+                      (list 'syntax-quote (second e))
+                      (list 'syntax-quote e))))
+          form)))
+
+(defn split-splices "" [form fn-name]
+  (defn make-splice "" [form]
+    (if (or (self-evaluating? form)
+            (symbol? form))
+        (apply-unquoted-form fn-name (list form))
+        (apply-unquoted-form fn-name form)))
+  (loop [nodes form
+         slices '()
+         acc '()]
+   (if (empty? nodes)
+       (reverse
+        (if (empty? acc)
+            slices
+            (cons (make-splice (reverse acc)) slices)))
+       (let [node (first nodes)]
+        (if (unquote-splicing? node)
+            (recur (rest nodes)
+                   (cons (second node)
+                         (if (empty? acc)
+                             slices
+                             (cons (make-splice (reverse acc)) slices)))
+                   '())
+            (recur (rest nodes)
+                   slices
+                   (cons node acc)))))))
+
+
+(defn syntax-quote-split
+  [append-name fn-name form]
+  (let [slices (split-splices form fn-name)
+        n (count slices)]
+    (cond (identical? n 0) (list fn-name)
+          (identical? n 1) (first slices)
+          :default (apply-form append-name slices))))
+
+
+;; compiler
+
+(defn compile-object
+  ""
+  [form quoted?]
+  ;; TODO: Add regexp to the list.
+  (cond
+    (keyword? form) (write-keyword form)
+    (symbol? form) (write-symbol form)
+    (number? form) (write-number form)
+    (string? form) (write-string form)
+    (boolean? form) (write-boolean form)
+    (nil? form) (write-nil form)
+    (re-pattern? form) (compile-re-pattern form)
+    (vector? form) (compile (apply-form 'vector
+                                        (apply list form)
+                                        quoted?))
+    (list? form) (compile (apply-form 'list
+                                      form
+                                      quoted?))
+    (dictionary? form) (compile-dictionary
+                        (if quoted?
+                          (map-dictionary form (fn [x] (list 'quote x)))
+                          form))))
+
+(defn compile-syntax-quoted-vector
+  [form]
+  (let [concat-form (syntax-quote-split 'concat 'vector (apply list form))]
+    (compile (if (> (count concat-form) 1)
+              (list 'vec concat-form)
+              concat-form))))
+
+(defn compile-syntax-quoted
+  ""
+  [form]
+  (cond
+   (list? form) (compile (syntax-quote-split 'concat 'list form))
+   (vector? form) (compile-syntax-quoted-vector form)
+   ; Disable dictionary form as we can't fully support it yet.
+   ; (dictionary? form) (compile (syntax-quote-split 'merge 'dictionary form))
+   :else (compile-object form)))
+
+(defn compile
+  "compiles given form"
+  [form]
+  (cond
+   (self-evaluating? form) (compile-object form)
+   (symbol? form) (write-reference form)
+   (keyword? form) (write-keyword-reference form)
+   (vector? form) (compile-object form)
+   (dictionary? form) (compile-object form)
+   (list? form)
+    (let [head (first form)]
+      (cond
+       (empty? form) (compile-object form true)
+       (quote? form) (compile-object (second form) true)
+       (syntax-quote? form) (compile-syntax-quoted (second form))
+       (special? head) (execute-special head form)
+       ;; Compile keyword invoke as a property access.
+       (keyword? head) (compile `(get ~(second form) ~head))
+       :else (do
+              (if (not (or (symbol? head) (list? head)))
+                (throw (compiler-error
+                        form
+                        (str "operator is not a procedure: " head)))
+              (compile-invoke form)))))))
+
+(defn compile*
+  "compiles all forms"
+  [forms]
+  (reduce (fn [result form]
+            (str result
+                 (if (empty? result) "" ";\n\n")
+                 (compile (if (list? form)
+                            (with-meta (macroexpand form)
+                              (conj {:top true} (meta form)))
+                            form))))
+          ""
+          forms))
+
+(defn compile-program
+  "compiles all expansions"
+  [forms]
+  (reduce (fn [result form]
+            (str result
+                 (if (empty? result) "" ";\n\n")
+                 (compile (if (list? form)
+                            (with-meta (macroexpand form)
+                              (conj {:top true} (meta form)))
+                            form))))
+          ""
+          forms))
+
+(defn macroexpand-1
+  "If form represents a macro form, returns its expansion,
+  else returns form."
+  [form]
+  (if (list? form)
+    (let [op (first form)
+          id (if (symbol? op) (name op))]
+      (cond
+        (special? op) form
+        (macro? op) (execute-macro op (rest form))
+        (and (symbol? op)
+             (not (identical? id ".")))
+          ;; (.substring s 2 5) => (. s substring 2 5)
+          (if (identical? (first id) ".")
+            (if (< (count form) 2)
+              (throw (Error
+                "Malformed member expression, expecting (.member target ...)"))
+              (cons '.
+                    (cons (second form)
+                          (cons (symbol (subs id 1))
+                                (rest (rest form))))))
+
+            ;; (StringBuilder. "foo") => (new StringBuilder "foo")
+            (if (identical? (last id) ".")
+              (cons 'new
+                    (cons (symbol (subs id 0 (dec (count id))))
+                          (rest form)))
+              form))
+        :else form))
+      form))
+
+(defn macroexpand
+  "Repeatedly calls macroexpand-1 on form until it no longer
+  represents a macro form, then returns it."
+  [form]
+  (loop [original form
+         expanded (macroexpand-1 form)]
+    (if (identical? original expanded)
+      original
+      (recur expanded (macroexpand-1 expanded)))))
+
+
+
+;; backend specific compiler hooks
+
+(def *line-break-pattern* #"(?m)\n(?=[^\n])")
+(defn indent
+  [code indentation]
+  (join indentation (split code *line-break-pattern*)))
+
+(defn compile-template
+  "Compiles given template"
+  [form]
+  (let [indent-pattern #"\n *$"
+
+        get-indentation (fn [code] (or (re-find indent-pattern code) "\n"))]
+    (loop [code ""
+           parts (split (first form) "~{}")
+           values (rest form)]
+      (if (> (count parts) 1)
+        (recur
+         (str
+          code
+          (first parts)
+          (indent (str (first values))
+                  (get-indentation (first parts))))
+         (rest parts)
+         (rest values))
+        (str code (first parts))))))
+
+(defn compile-def
+  "Creates and interns or locates a global var with the name of symbol
+  and a namespace of the value of the current namespace (*ns*). If init
+  is supplied, it is evaluated, and the root binding of the var is set
+  to the resulting value. If init is not supplied, the root binding of
+  the var is unaffected. def always applies to the root binding, even if
+  the var is thread-bound at the point where def is called. def yields
+  the var itself (not its value)."
+  [form]
+  (let [id (first form)
+        export? (and (:top (or (meta form) {}))
+                     (not (:private (or (meta id) {}))))
+        attribute (symbol (namespace id)
+                          (str "-" (name id)))]
+    (if export?
+      (compile-template (list "var ~{};\n~{}"
+                               (compile (cons 'set! form))
+                               (compile `(set! (. exports ~attribute) ~id))))
+      (compile-template (list "var ~{}"
+                              (compile (cons 'set! form)))))))
+
+(defn compile-if-else
+  "Evaluates test. If not the singular values nil or false,
+  evaluates and yields then, otherwise, evaluates and yields else.
+  If else is not supplied it defaults to nil. All of the other
+  conditionals in Clojure are based upon the same logic, that is,
+  nil and false constitute logical falsity, and everything else
+  constitutes logical truth, and those meanings apply throughout."
+  [form]
+  (let [condition (macroexpand (first form))
+        then-expression (macroexpand (second form))
+        else-expression (macroexpand (third form))]
+    (compile-template
+      (list
+        (if (and (list? else-expression)
+                 (= (first else-expression) 'if))
+          "~{} ?\n  ~{} :\n~{}"
+          "~{} ?\n  ~{} :\n  ~{}")
+        (compile condition)
+        (compile then-expression)
+        (compile else-expression)))))
+
+(defn compile-dictionary
+  "Compiles dictionary to JS object"
+  [form]
+  (let [body
+        (loop [body nil
+               names (keys form)]
+          (if (empty? names)
+            body
+            (recur
+             (str
+              (if (nil? body) "" (str body ",\n"))
+              (compile-template
+               (list
+                "~{}: ~{}"
+                (compile (first names))
+                (compile (macroexpand
+                          (get form (first names)))))))
+             (rest names))))
+        ]
+      (if (nil? body) "{}" (compile-template (list "{\n  ~{}\n}" body)))))
+
+
+;; Function parser / compiler
+
+
+(defn desugar-fn-name [form]
+  (if (or (symbol? (first form))
+          (nil? (first form)))
+    form
+    (cons nil form)))
+
+(defn desugar-fn-doc [form]
+  (if (or (string? (second form))
+          (nil? (second form)))
+    form
+    (cons (first form) ;; (name nil ... )
+          (cons nil (rest form)))))
+
+(defn desugar-fn-attrs [form]
+  (if (or (dictionary? (third form))
+          (nil? (third form)))
+    form
+    (cons (first form) ;; (name nil ... )
+          (cons (second form)
+                (cons nil (rest (rest form)))))))
+
+(defn compile-desugared-fn
+  ;"(fn name? [params* ] exprs*)
+  ;Defines a function (fn)"
+  [name doc attrs params body]
+  (compile-template
+    (if (nil? name)
+      (list "function(~{}) {\n  ~{}\n}"
+            (join ", " (map compile (:names params)))
+            (compile-fn-body (map macroexpand body) params))
+      (list "function ~{}(~{}) {\n  ~{}\n}"
+            (compile name)
+            (join ", " (map compile (:names params)))
+            (compile-fn-body (map macroexpand body) params)))))
+
+(defn compile-statements
+  [form prefix]
+  (loop [result ""
+         expression (first form)
+         expressions (rest form)]
+    (if (empty? expressions)
+      (str result
+           (if (nil? prefix) "" prefix)
+           (compile (macroexpand expression))
+           ";")
+      (recur
+        (str result (compile (macroexpand expression)) ";\n")
+        (first expressions)
+        (rest expressions)))))
+
+(defn compile-fn-body
+  [form params]
+  (if (and (dictionary? params) (:rest params))
+    (compile-statements
+      (cons (list 'def
+                  (:rest params)
+                  (list
+                    'Array.prototype.slice.call
+                    'arguments
+                    (:arity params)))
+      form)
+      "return ")
+
+    ;; Optimize functions who's body only contains `let` form to avoid
+    ;; function call overhead.
+    (if (and (identical? (count form) 1)
+             (list? (first form))
+             (= (first (first form)) 'do))
+      (compile-fn-body (rest (first form)) params)
+      (compile-statements form "return "))))
+
+(defn desugar-params
+  "Returns map like `{:names ['foo 'bar] :rest 'baz}` if takes non-variadic
+  number of params `:rest` is `nil`"
+  [params]
+  (loop [names []
+         params params]
+    (cond (empty? params) {:names names :arity (count names) :rest nil}
+          (= (first params) '&)
+            (cond (= (count params) 1) {:names names
+                                        :arity (count names)
+                                        :rest nil}
+                  (= (count params) 2) {:names names
+                                        :arity (count names)
+                                        :rest (second params)}
+                  :else (throw (TypeError
+                                "Unexpected number of parameters after &")))
+          :else (recur (conj names (first params)) (rest params)))))
+
+(defn analyze-overloaded-fn
+  "Compiles function that has overloads defined"
+  [name doc attrs overloads]
+  (map (fn [overload]
+         (let [params (desugar-params (first overload))]
+           {:rest (:rest params)
+            :names (:names params)
+            :arity (:arity params)
+            :body (rest overload)}))
+       overloads))
+
+(defn compile-overloaded-fn
+  [name doc attrs overloads]
+  (let [methods (analyze-overloaded-fn name doc attrs overloads)
+        fixed-methods (filter (fn [method] (not (:rest method))) methods)
+        variadic (first (filter (fn [method] (:rest method)) methods))
+        names (reduce (fn [names params]
+                        (if (> (count names) (:arity params))
+                              names
+                              (:names params)))
+                      []
+                      methods)]
+    (list 'fn name doc attrs names
+          (list 'raw*
+                (compile-switch
+                  'arguments.length
+                  (map (fn [method]
+                        (cons (:arity method)
+                          (list 'raw*
+                                (compile-fn-body
+                                  (concat
+                                    (compile-rebind names (:names method))
+                                    (:body method))))))
+                        fixed-methods)
+                  (if (nil? variadic)
+                    '(throw (Error "Invalid arity"))
+                    (list 'raw*
+                          (compile-fn-body
+                            (concat
+                              (compile-rebind
+                                (cons `(Array.prototype.slice.call
+                                        arguments
+                                        ~(:arity variadic))
+                                      names)
+                                (cons (:rest variadic)
+                                      (:names variadic)))
+                              (:body variadic)))))))
+          nil)))
+
+
+(defn compile-rebind
+  "Takes vector of bindings and a vector of names this binding needs to
+  get bound to and returns list of def expressions that bind bindings to
+  a new names. If names matches associated binding it will be ignored."
+  [bindings names]
+  ;; Loop through the given names and bindings and assembling a `form`
+  ;; list containing set expressions.
+  (loop [form '()
+         bindings bindings
+         names names]
+    ;; If all the names have bing iterated return reversed form. Form is
+    ;; reversed since later bindings will be cons-ed later, appearing in
+    ;; inverse order.
+    (if (empty? names)
+      (reverse form)
+      (recur
+       ;; If name and binding are identical then rebind is unnecessary
+       ;; and it's skipped. Also not skipping such rebinds could be
+       ;; problematic as definitions may shadow bindings.
+       (if (= (first names) (first bindings))
+         form
+         (cons (list 'def (first names) (first bindings)) form))
+       (rest bindings)
+       (rest names)))))
+
+(defn compile-switch-cases
+  [cases]
+  (reduce
+   (fn [form case-expression]
+     (str form
+          (compile-template
+           (list "case ~{}:\n  ~{}\n"
+                 (compile (macroexpand (first case-expression)))
+                 (compile (macroexpand (rest case-expression)))))))
+   ""
+   cases))
+
+
+(defn compile-switch
+  [value cases default-case]
+  (compile-template
+   (list "switch (~{}) {\n  ~{}\n  default:\n    ~{}\n}"
+         (compile (macroexpand value))
+         (compile-switch-cases cases)
+         (compile (macroexpand default-case)))))
+
+(defn compile-fn
+  "(fn name? [params* ] exprs*)
+
+  Defines a function (fn)"
+  [form]
+  (let [signature (desugar-fn-attrs (desugar-fn-doc (desugar-fn-name form)))
+        name (first signature)
+        doc (second signature)
+        attrs (third signature)]
+    (if (vector? (third (rest signature)))
+      (compile-desugared-fn name doc attrs
+                            (desugar-params (third (rest signature)))
+                            (rest (rest (rest (rest signature)))))
+      (compile
+        (compile-overloaded-fn name doc attrs (rest (rest (rest signature))))))))
+
+(defn compile-invoke
+  [form]
+  (compile-template
+   ;; Wrap functions returned by expressions into parenthesis.
+   (list (if (list? (first form)) "(~{})(~{})" "~{}(~{})")
+         (compile (first form))
+         (compile-group (rest form)))))
+
+(defn compile-group
+  [form wrap]
+  (if wrap
+    (str "(" (compile-group form) ")")
+    (join ", " (vec (map compile (map  macroexpand form))))))
+
+(defn compile-do
+  "Evaluates the expressions in order and returns the value of the last.
+  If no expressions are supplied, returns nil."
+  [form]
+  (compile (list (cons 'fn (cons [] form)))))
+
+
+(defn define-bindings
+  "Returns list of binding definitions"
+  [form]
+  (loop [defs '()
+         bindings form]
+    (if (identical? (count bindings) 0)
+      (reverse defs)
+      (recur
+        (cons
+          (list 'def                ; '(def (get bindings 0) (get bindings 1))
+                (get bindings 0)    ; binding name
+                (get bindings 1))   ; binding value
+           defs)
+        (rest (rest bindings))))))
+
+(defn compile-throw
+  "The expression is evaluated and thrown, therefore it should yield an error."
+  [form]
+  (compile-template
+    (list "(function() { throw ~{}; })()"
+          (compile (macroexpand (first form))))))
+
+(defn compile-set
+  "Assignment special form.
+
+  When the first operand is a field member access form, the assignment
+  is to the corresponding field."
+  ; {:added "1.0", :special-form true, :forms '[(loop [bindings*] exprs*)]}
+  [form]
+  (compile-template
+    (list "~{} = ~{}"
+      (compile (macroexpand (first form)))
+      (compile (macroexpand (second form))))))
+
+(defn compile-vector
+  "Creates a new vector containing the args"
+  [form]
+  (compile-template (list "[~{}]" (compile-group form))))
+
+
+(defn compile-try
+  "The exprs are evaluated and, if no exceptions occur, the value
+  of the last is returned. If an exception occurs and catch clauses
+  are provided, its exprs are evaluated in a context in which name is
+  bound to the thrown exception, and the value of the last is the return
+  value of the function. If there is no matching catch clause, the exception
+  propagates out of the function. Before returning, normally or abnormally,
+  any finally exprs will be evaluated for their side effects."
+  [form]
+  (loop [try-exprs '()
+         catch-exprs '()
+         finally-exprs '()
+         exprs (reverse form)]
+    (if (empty? exprs)
+      (if (empty? catch-exprs)
+        (compile-template
+          (list
+            "(function() {\ntry {\n  ~{}\n} finally {\n  ~{}\n}})()"
+            (compile-fn-body try-exprs)
+            (compile-fn-body finally-exprs)))
+        (if (empty? finally-exprs)
+          (compile-template
+            (list
+              "(function() {\ntry {\n  ~{}\n} catch (~{}) {\n  ~{}\n}})()"
+              (compile-fn-body try-exprs)
+              (compile (first catch-exprs))
+              (compile-fn-body (rest catch-exprs))))
+          (compile-template
+            (list
+              "(function() {\ntry {\n  ~{}\n} catch (~{}) {\n  ~{}\n} finally {\n  ~{}\n}})()"
+              (compile-fn-body try-exprs)
+              (compile (first catch-exprs))
+              (compile-fn-body (rest catch-exprs))
+              (compile-fn-body finally-exprs)))))
+        (if (= (first (first exprs)) 'catch)
+          (recur try-exprs
+                 (rest (first exprs))
+                 finally-exprs
+                 (rest exprs))
+          (if (= (first (first exprs)) 'finally)
+            (recur try-exprs
+                   catch-exprs
+                   (rest (first exprs))
+                   (rest exprs))
+            (recur (cons (first exprs) try-exprs)
+                   catch-exprs
+                   finally-exprs
+                   (rest exprs)))))))
+
+(defn compile-property
+  "(. object method arg1 arg2)
+
+  The '.' special form that can be considered to be a method call,
+  operator"
+  [form]
+  ;; (. object method arg1 arg2) -> (object.method arg1 arg2)
+  ;; (. object -property) -> object.property
+  (if (identical? (aget (name (second form)) 0) "-")
+    (compile-template
+      (list (if (list? (first form)) "(~{}).~{}" "~{}.~{}")
+            (compile (macroexpand (first form)))
+            (compile (macroexpand (symbol (subs (name (second form)) 1))))))
+    (compile-template
+      (list "~{}.~{}(~{})"
+            (compile (macroexpand (first form)))    ;; object name
+            (compile (macroexpand (second form)))   ;; method name
+            (compile-group (rest (rest form)))))))  ;; args
+
+(defn compile-apply
+  [form]
+  (compile
+    (list '.
+          (first form)
+          'apply
+          (first form)
+          (second form))))
+
+(defn compile-new
+  "(new Classname args*)
+  Compiles new special form. The args, if any, are evaluated
+  from left to right, and passed to the constructor of the
+  class named by Classname. The constructed object is returned."
+  ; {:added "1.0", :special-form true, :forms '[(new Classname args*)]}
+  [form]
+  (compile-template (list "new ~{}" (compile form))))
+
+(defn compile-aget
+  "Compiles compound property accessor"
+  [form]
+  (let [target (macroexpand (first form))
+        attribute (macroexpand (second form))
+        not-found (third form)
+        template (if (list? target) "(~{})[~{}]" "~{}[~{}]")]
+    (if not-found
+      (compile (list 'or
+                     (list 'get (first form) (second form))
+                     (macroexpand not-found)))
+      (compile-template
+       (list template (compile target) (compile attribute))))))
+
+(defn compile-get
+  [form]
+  (compile-aget (cons (list 'or (first form) 0)
+                      (rest form))))
+
+(defn compile-instance
+  "Evaluates x and tests if it is an instance of the class
+  c. Returns true or false"
+  [form]
+  (compile-template (list "~{} instanceof ~{}"
+                          (compile (macroexpand (second form)))
+                          (compile (macroexpand (first form))))))
+
+
+(defn compile-not
+  "Returns true if x is logical false, false otherwise."
+  [form]
+  (compile-template (list "!(~{})" (compile (macroexpand (first form))))))
+
+
+(defn compile-loop
+  "Evaluates the body in a lexical context in which the symbols
+  in the binding-forms are bound to their respective
+  initial-expressions or parts therein. Acts as a recur target."
+  [form]
+  (let [bindings (loop [names []
+                        values []
+                        tokens (first form)]
+                  (if (empty? tokens)
+                    {:names names :values values}
+                    (recur (conj names (first tokens))
+                           (conj values (second tokens))
+                           (rest (rest tokens)))))
+        names (:names bindings)
+        values (:values bindings)
+        body (rest form)]
+    ;; `((fn loop []
+    ;;    ~@(define-bindings bindings)
+    ;;    ~@(compile-recur body names)))
+    (compile
+      (cons (cons 'fn
+              (cons 'loop
+                (cons names
+                  (compile-recur names body))))
+            (apply list values)))))
+
+(defn rebind-bindings
+  "Rebinds given bindings to a given names in a form of
+  (set! foo bar) expressions"
+  [names values]
+  (loop [result '()
+         names names
+         values values]
+    (if (empty? names)
+      (reverse result)
+      (recur
+       (cons (list 'set! (first names) (first values)) result)
+       (rest names)
+       (rest values)))))
+
+(defn expand-recur
+  "Expands recur special form into params rebinding"
+  [names body]
+  (map (fn [form]
+         (if (list? form)
+           (if (= (first form) 'recur)
+             (list 'raw*
+                   (compile-group
+                    (concat
+                      (rebind-bindings names (rest form))
+                      (list 'loop))
+                    true))
+             (expand-recur names form))
+           form))
+        body))
+
+(defn compile-recur
+  "Eliminates tail calls in form of recur and rebinds the bindings
+  of the recursion point to the parameters of the recur"
+  [names body]
+  (list
+    (list 'raw*
+          (compile-template
+          (list "var recur = loop;\nwhile (recur === loop) {\n  recur = ~{}\n}"
+                (compile-statements (expand-recur names body)))))
+    'recur))
+
+(defn compile-raw
+  "returns form back since it's already compiled"
+  [form]
+  (first form))
+
+(install-special 'set! compile-set)
+(install-special 'get compile-get)
+(install-special 'aget compile-aget)
+(install-special 'def compile-def)
+(install-special 'if compile-if-else)
+(install-special 'do compile-do)
+(install-special 'do* compile-statements)
+(install-special 'fn compile-fn)
+(install-special 'throw compile-throw)
+(install-special 'vector compile-vector)
+(install-special 'try compile-try)
+(install-special '. compile-property)
+(install-special 'apply compile-apply)
+(install-special 'new compile-new)
+(install-special 'instance? compile-instance)
+(install-special 'not compile-not)
+(install-special 'loop compile-loop)
+(install-special 'raw* compile-raw)
+(install-special 'comment write-comment)
+
+
+(defn compile-re-pattern
+  [form]
+  (str form))
+
+(defn install-native
+  "Creates an adapter for native operator"
+  [alias operator validator fallback]
+  (install-special
+   alias
+   (fn [form]
+    (if (empty? form)
+      fallback
+      (reduce
+        (fn [left right]
+          (compile-template
+            (list "~{} ~{} ~{}"
+                  left
+                  (name operator)
+                  right)))
+        (map (fn [operand]
+              (compile-template
+                (list (if (list? operand) "(~{})" "~{}")
+                  (compile (macroexpand operand)))))
+             form))))
+    validator))
+
+(defn install-operator
+  "Creates an adapter for native operator that does comparison in
+  monotonical order"
+  [alias operator]
+  (install-special
+   alias
+   (fn [form]
+    (loop [result ""
+           left (first form)
+           right (second form)
+           operands (rest (rest form))]
+      (if (empty? operands)
+        (str result
+             (compile-template (list "~{} ~{} ~{}"
+                                     (compile (macroexpand left))
+                                     (name operator)
+                                     (compile (macroexpand right)))))
+        (recur
+          (str result
+              (compile-template (list "~{} ~{} ~{} && "
+                                      (compile (macroexpand left))
+                                      (name operator)
+                                      (compile (macroexpand right)))))
+          right
+          (first operands)
+          (rest operands)))))
+   verify-two))
+
+
+(defn compiler-error
+  [form message]
+  (let [error (Error (str message))]
+    (set! error.line 1)
+    (throw error)))
+
+
+(defn verify-two
+  [form]
+  (if (or (empty? (rest form))
+          (empty? (rest (rest form))))
+    (throw
+      (compiler-error
+        form
+        (str (first form) " form requires at least two operands")))))
+
+;; Arithmetic Operators
+(install-native '+ '+ nil 0)
+(install-native '- '- nil "NaN")
+(install-native '* '* nil 1)
+(install-native '/ '/ verify-two)
+(install-native 'mod (symbol "%") verify-two)
+
+;; Logical Operators
+(install-native 'and '&&)
+(install-native 'or '||)
+
+;; Comparison Operators
+
+(install-operator 'not= '!=)
+(install-operator '== '===)
+(install-operator 'identical? '===)
+(install-operator '> '>)
+(install-operator '>= '>=)
+(install-operator '< '<)
+(install-operator '<= '<=)
+
+;; Bitwise Operators
+
+(install-native 'bit-and '& verify-two)
+(install-native 'bit-or '| verify-two)
+(install-native 'bit-xor (symbol "^"))
+(install-native 'bit-not (symbol "~") verify-two)
+(install-native 'bit-shift-left '<< verify-two)
+(install-native 'bit-shift-right '>> verify-two)
+(install-native 'bit-shift-right-zero-fil '>>> verify-two)
+
+
+(install-macro
+ 'str
+ (fn str
+   "str inlining and optimization via macros"
+   [& forms]
+   `(+ "" ~@forms)))
+
+(install-macro
+  'let
+  (fn let-macro
+    "Evaluates the exprs in a lexical context in which the symbols in
+    the binding-forms are bound to their respective init-exprs or parts
+    therein."
+    {:added "1.0" :special-form true :forms '[(let [bindings*] exprs*)]}
+    [bindings & body]
+    ;; TODO: Implement destructure for bindings:
+    ;; https://github.com/clojure/clojure/blob/master/src/clj/clojure/core.clj#L3937
+    ;; Consider making let a macro:
+    ;; https://github.com/clojure/clojure/blob/master/src/clj/clojure/core.clj#L3999
+    (cons 'do
+      (concat (define-bindings bindings) body))))
+
+(install-macro
+ 'cond
+ (fn cond
+   "Takes a set of test/expr pairs. It evaluates each test one at a
+   time.  If a test returns logical true, cond evaluates and returns
+   the value of the corresponding expr and doesn't evaluate any of the
+   other tests or exprs. (cond) returns nil."
+   {:added "1.0"}
+   [& clauses]
+   (if (not (empty? clauses))
+     (list 'if (first clauses)
+           (if (empty? (rest clauses))
+             (throw (Error "cond requires an even number of forms"))
+             (second clauses))
+           (cons 'cond (rest (rest clauses)))))))
+
+(install-macro
+ 'defn
+ (fn defn
+   "Same as (def name (fn [params* ] exprs*)) or
+   (def name (fn ([params* ] exprs*)+)) with any doc-string or attrs added
+   to the var metadata"
+   {:added "1.0" :special-form true }
+   [name & body]
+   `(def ~name (fn ~name ~@body))))
+
+(install-macro
+ 'defn-
+ (fn defn
+   "Same as (def name (fn [params* ] exprs*)) or
+   (def name (fn ([params* ] exprs*)+)) with any doc-string or attrs added
+   to the var metadata"
+   {:added "1.0" :special-form true }
+   [name & body]
+   `(defn ~(with-meta name (conj {:private true} (meta name))) ~@body)))
+
+(install-macro
+ 'assert
+ (fn assert
+   "Evaluates expr and throws an exception if it does not evaluate to
+   logical true."
+   {:added "1.0"}
+   [x message]
+   (let [title (or message "")
+         assertion (pr-str x)
+         uri (:uri x)
+         form (if (list? x) (second x) x)]
+     `(do
+        (if (and (not (identical? (typeof **verbose**) "undefined"))
+                 **verbose**)
+          (.log console "Assert:" ~assertion))
+        (if (not ~x)
+          (throw (Error. (str "Assert failed: "
+                              ~title
+                              "\n\nAssertion:\n\n"
+                              ~assertion
+                              "\n\nActual:\n\n"
+                              ~form
+                              "\n--------------\n")
+                         ~uri)))))))
+
+(install-macro
+ 'import
+ (fn
+   "Helper macro for importing node modules"
+   [imports path]
+   (if (nil? path)
+     `(require ~imports)
+     (if (symbol? imports)
+       `(def ~(with-meta imports {:private true}) (require ~path))
+       (loop [form '() names imports]
+         (if (empty? names)
+           `(do* ~@form)
+           (let [alias (first names)
+                 id (symbol (str ".-" (name alias)))]
+             (recur (cons `(def ~(with-meta alias {:private true})
+                             (~id (require ~path))) form)
+                    (rest names)))))))))
+
+(defn expand-ns
+  "Sets *ns* to the namespace named by name (unevaluated), creating it
+  if needed. references can be zero or more of: (:refer-clojure ...)
+  (:require ...) (:use ...) (:import ...) (:load ...) (:gen-class)
+  with the syntax of refer-clojure/require/use/import/load/gen-class
+  respectively, except the arguments are unevaluated and need not be
+  quoted. (:gen-class ...), when supplied, defaults to :name
+  corresponding to the ns name, :main true, :impl-ns same as ns, and
+  :init-impl-ns true. All options of gen-class are
+  supported. The :gen-class directive is ignored when not
+  compiling. If :gen-class is not supplied, when compiled only an
+  nsname__init.class will be generated. If :refer-clojure is not used, a
+  default (refer 'clojure) is used. Use of ns is preferred to
+  individual calls to in-ns/require/use/import:
+
+  (ns foo.bar
+  (:refer-clojure :exclude [ancestors printf])
+  (:require (clojure.contrib sql combinatorics))
+  (:use (my.lib this that))
+  (:import (java.util Date Timer Random)
+  (java.sql Connection Statement)))"
+  [id & params]
+  (let [ns (str id)
+        ;; ns-root is used for resolving requirements
+        ;; relatively if they're under same root.
+        requirer (split ns \.)
+        doc (if (string? (first params))
+              (first params)
+              nil)
+        args (if doc (rest params) params)
+        parse-references (fn [forms]
+                           (reduce (fn [references form]
+                                     (set! (get references (name (first form)))
+                                           (vec (rest form)))
+                                     references)
+                                   {}
+                                   forms))
+        references (parse-references args)
+
+        id->path (fn id->path [id]
+                   (let [requirement (split (str id) \.)
+                         relative? (identical? (first requirer)
+                                               (first requirement))]
+                     (if relative?
+                       (loop [from requirer
+                              to requirement]
+                         (if (identical? (first from)
+                                         (first to))
+                           (recur (rest from) (rest to))
+                           (join \/
+                                 (concat [\.]
+                                         (repeat (dec (count from)) "..")
+                                         to))))
+                       (join \/ requirement))))
+
+        make-require (fn [from as name]
+                       (let [path (id->path from)
+                             requirement (if name
+                                           `(. (require ~path) ~(symbol nil (str \- name)))
+                                           `(require ~path))]
+                         (if as
+                           `(def ~as ~requirement)
+                           requirement)))
+
+        expand-requirement (fn [form]
+                             (let [from (first form)
+                                   as (and (identical? ':as (second form))
+                                             (third form))]
+                               (make-require from as)))
+
+        expand-use (fn [form]
+                     (let [from (first form)
+                           directives (apply dictionary (vec (rest form)))
+                           names (get directives ':only)
+                           renames (get directives ':rename)
+
+                           named-imports (and names
+                                              (map (fn [name] (make-require from name name))
+                                                   names))
+
+                           renamed-imports (and renames
+                                                (map (fn [pair]
+                                                       (make-require from
+                                                                     (second pair)
+                                                                     (first pair)))
+                                                     renames))]
+                       (assert (or names renames)
+                               (str "Only [my.lib :only [foo bar]] form & "
+                                    "[clojure.string :rename {replace str-replace} are supported"))
+                       (concat [] named-imports renamed-imports)))
+
+        require-forms (:require references)
+        use-forms (:use references)
+        requirements (if require-forms
+                       (map expand-requirement require-forms))
+        uses (if use-forms
+               (apply concat (map expand-use use-forms)))]
+
+    (concat
+     (list 'do*
+           ;; Sets *ns* to the namespace named by name
+           `(def *ns* ~ns)
+           `(set! (.-namespace module) *ns*))
+     (if doc [`(set! (.-description module) ~doc)])
+     requirements
+     uses)))
+
+(install-macro 'ns expand-ns)
+
+(install-macro
+ 'print
+ (fn [& more]
+   "Prints the object(s) to the output for human consumption."
+   `(.log console ~@more)))