(import [read-from-string] "./reader") (import [meta with-meta symbol? symbol keyword? keyword namespace unquote? unquote-splicing? quote? syntax-quote? name gensym pr-str] "./ast") (import [empty? count list? list first second third rest cons conj reverse reduce vec last map filter take concat] "./sequence") (import [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 = ==] "./runtime") (import [split join upper-case replace] "./string") (def **specials** {}) (defn compile-reference "Translates references from clojure convention to JS: **macros** __macros__ list->vector listToVector set! set foo_bar foo_bar number? isNumber create-server createServer" [form] (def id (name form)) (set! id (cond (identical? id "*") "multiply" (identical? id "/") "divide" (identical? id "+") "sum" (identical? id "-") "subtract" (identical? id "=") "equal?" (identical? id "==") "strict-equal?" (identical? id "<=") "not-greater-than" (identical? id ">=") "not-less-than" (identical? id ">") "greater-than" (identical? id "<") "less-than" :else id)) ;; **macros** -> __macros__ (set! id (join "_" (split id "*"))) ;; list->vector -> listToVector (set! id (join "-to-" (split id "->"))) ;; set! -> set (set! id (join (split id "!"))) (set! id (join "$" (split id "%"))) ;; foo= -> fooEqual ;(set! id (join "-equal-" (split id "=")) ;; foo+bar -> fooPlusBar (set! id (join "-plus-" (split id "+"))) (set! id (join "-and-" (split id "&"))) ;; number? -> isNumber (set! id (if (identical? (last id) "?") (str "is-" (subs id 0 (dec (count id)))) id)) ;; create-server -> createServer (set! id (reduce (fn [result key] (str result (if (and (not (empty? result)) (not (empty? key))) (str (upper-case (get key 0)) (subs key 1)) key))) "" (split id "-"))) id) (defn write-keyword [form] (str "\"" (name form) "\"")) (defn write-comment [form] (write-template (list "//~{}\n" (first form)))) (def ^:private *indent-pattern* #"\n *$") (def ^:private *line-break-pattern #"(?m)\n") ;; if not then (RegExp "\n" "g") (defn- get-indentation [code] (or (re-find *indent-pattern* code) "\n")) (defn write-template [template form] (loop [code "" parts (split template "~{}") values form] (if (> (count parts) 1) (recur (str code (first parts) (replace (str "" (first values)) line-break-pattern (get-indentation (first parts))) (rest parts) (rest values) (str code (first parts))))))) (defn- write-dictionary-pair [pair] (let [key (first pair) value (second pair)] (compile-template "~{}: ~{}\n" (write key) (write vaulue)))) (defn write-dictionary "Compiles dictionary to JS object" [form] (let [pairs (key-values form) entries (map write-dictionary-pair pairs)] (if (empty? pairs) "~{}" (write-template "{\n ~{}}" (reduce str "" entries))))) (defn write-fn [form] (let [doc (:doc form) attrs (:attrs form) name (first form) params (second form) body (rest (rest form)) ] (if (nil? name) (list "function(~{}) {\n ~{}\n}" (join ", " (map write params)) (write-expressions (map write body)) (list "function ~{}(~{}) {\n ~{}\n}" (write name) (join ", " (map write params)) (write-expressions (map write body))))))) (defn write-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 write-call [form] {:type :CallExpression :callee (write (first form)) :arguments (map write (vec (rest params)))}) (defn- write-property [pair] {:type :Property :key (write (first pair)) :value (write (second pair)) :kind :init}) (def **specials** {}) (defn special? "Returns true if special form" [operator] (and (symbol? operator) (get **specials** operator) true)) (defn- write-special [form] ((get **specials** (first form)) (with-meta (rest form) (meta form)))) (defmacro defoperator "Installs special function" [operator & body] `(set-operator! (quote ~operator) (fn ~@body))) (defn set-operator! [operator fn] `(set! (get **specials** (name operator)) fn)) (defoperator set! [form] {:type :AssignmentExpression :operator := :left (write (first form)) :right (write (second form))}) (defoperator get [form] (let [property (write (second form))] {:type :MemberExpression :computed true :object (write (first form)) :property (write (second form))})) (defoperator 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 (meta form)) (not (:private (meta id)))) attribute (symbol (namespace id) (str "-" (name id))) declaration {:type :VariableDeclaration :kind :var :declarations [{:type :VariableDeclarator :id (write id) :init (write (second form))}]}] (if export? [declaration (write (set! (get exports ~attribute) ~id))] declaration))) (defoperator if "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] {:type :ConditionalExpression :test (write (first form)) :consequent (second form) :alternate (third form)}) (defoperator do [form] ) (defoperator fn [form] ) (defoperator throw [form] {:type :ThrowStatement :argument (write (first form))}) (defn- try-handler? [form] (and (list? form) (or (= 'catch (first head)) (= 'finally (first head))))) (defn- analyze-handlers [form] (let [head (first form)] (if (and (list? head) (= 'catch (first head))) {:catch (rest head) :finally (rest (second form))} {:catch nil :finally head}))) (defn- analyze-try [form] (loop [metadata (meta form) head (first form) tail (rest form) result []] (cond (try-handler? head) (with-meta form (conj {} metadata {:try result} (analyze-handlers tail))) :else (recur (first tail) (rest tail) (conj result head))))) (defoperator try [form] (let [analyzed (analyze-try form) metadata (meta analyzed) try-block (:try metadata) catch-block (:catch metadata) finally-block (:finally metadata)] {:type :TryStatement :guardedHandlers [] :block (write-block try-block) :handlers (if catch-block [{:type :CatchClause :param (first catch-block) :body (write-block (rest catch-block))}] []) :finalizer (write-block finally-block)})) (defoperator new [form] {:type :NewExpression :callee (write (first form)) :arguments (map write (vec (rest form)))}) ;; Operators that compile to binary expressions (defn make-binary-expression [operator left right] {:type :BinaryExpression :operator operator :left left :right right}) (defmacro def-binary-operator [id operator default-operand make-operand] `(set-operator! (name ~id) (fn make-expression ([] (write ~default-operand)) ([operand] (write (~make-operand operand))) ([left right] (make-binary-expression ~operator (write left) (write right))) ([left & more] (make-binary-expression ~operator (write left) (apply make-expression right)))))) (defn verify-one [operator] (error (str operator "form requires at least one operand"))) (defn verify-two [operator] (error (str operator "form requires at least two operands"))) ;; Arithmetic operators (def-binary-operator :+ :+ 0 identity) (def-binary-operator :- :- 'NaN identity) (def-binary-operator :* :* 1 identity) (def-binary-operator (keyword "/") (keyword "/") verify-two verify-two) (def-binary-operator :mod (keyword "%") verify-two verify-two) ;; Comparison operators (def-binary-operator :not= :!= verify-one false) (def-binary-operator :== :=== verify-one true) (def-binary-operator :identical? '=== verify-two verify-two) (def-binary-operator :> :> verify-one true) (def-binary-operator :>= :>= verify-one true) (def-binary-operator :< :< verify-one true) (def-binary-operator :<= :<= verify-one true) ;; Bitwise Operators (def-binary-operator :bit-and :& verify-two verify-two) (def-binary-operator :bit-or :| verify-two verify-two) (def-binary-operator :bit-xor (keyword "^") verify-two verify-two) (def-binary-operator :bit-not (keyword "~") verify-two verify-two) (def-binary-operator :bit-shift-left :<< verify-two verify-two) (def-binary-operator :bit-shift-right :>> verify-two verify-two) (def-binary-operator :bit-shift-right-zero-fil :>>> verify-two verify-two) ;; Logical operators (defn make-logical-expression [operator left right] {:type :LogicalExpression :operator operator :left left :right right}) (defmacro def-logical-expression [id operator default-operand make-operand] `(set-operator! (name ~id) (fn make-expression ([] (write ~default-operand)) ([operand] (write (~make-operand operand))) ([left right] (make-logical-expression ~operator (write left) (write right))) ([left & more] (make-logical-expression ~operator (write left) (apply make-expression right)))))) (def-logical-expression :and :&& 'true identity) (def-logical-expression :and :|| 'nil identity) (defoperator . [form] {:type :CallExpression :callee {:type :MemberExpression :computed false :object (write (first form)) :property (write (second form))} :arguments (map write (vec (rest (rest params))))}) (defoperator instance? [form] {:type :BinaryExpression :operator :instanceof :left (write (second form)) :right (write (first form))}) (defoperator not [form] {:type :UnaryExpression :operator :! :argument (write (second form))}) (defn- write-list (let [operator (first form) body (rest form)] (cond (empty? form) (write-call '(list)) (keyword? operator) (write `(get (or ~body 0) ~operator)) (special? operator) (write-special form) (= 'set! operator) (write-set! body) (= 'get operator) (write-get body) (= 'def operator) (write-def body) (quote? form) (write-quoted (second form)) (syntax-quote? form) (write-syntax-quoted (second form)) ;; Compile keyword invoke as a property access. (keyword? head) (compile `(get (or ~(second form) 0) ~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 write [form] (cond (nil? form) {:type :UnaryExpression :operator :void :argument {:type :Literal :value 0}} (symbol? form) {:type :Identifier :name (name form)} (keyword? form) {:type :Literal :value (str "\"" (name form) "\"")} (pattern? form) {:type :Literal :value (str form)} (or (boolean? form) (number? form) (string? form)) {:type :Literal :value form} (vector? form) {:type :ArrayExpression :elements (map write form)} (dictionary? form) {:type :ObjectExpression :properties (map write-property (key-vals form))} (list? form) (write-list form))) (write-template (if (list? (first))) ;; 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-compound-accessor "Compiles compound property accessor" [form] (let [target (macroexpand (first form)) attribute (macroexpand (second form)) template (if (list? target) "(~{})[~{}]" "~{}[~{}]")] (compile-template (list template (compile target) (compile attribute))))) (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-compound-accessor) (install-special 'aget compile-compound-accessor) (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 compile-comment) (defn compile-keyword [form] (str "\"" "\uA789" (name form) "\"")) (defn compile-symbol [form] (compile (list 'symbol (namespace form) (name form)))) (defn compile-nil [form] "void(0)") (defn compile-number [form] form) (defn compile-boolean [form] (if (true? form) "true" "false")) (defn compile-string [form] (set! form (replace form (RegExp "\\\\" "g") "\\\\")) (set! form (replace form (RegExp "\n" "g") "\\n")) (set! form (replace form (RegExp "\r" "g") "\\r")) (set! form (replace form (RegExp "\t" "g") "\\t")) (set! form (replace form (RegExp "\"" "g") "\\\"")) (str "\"" form "\"")) (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)))))))))