diff options
-rw-r--r-- | luxc/src/lux/compiler.clj | 11 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js.clj | 187 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/base.clj | 243 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/cache.clj | 40 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/lux.clj | 387 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/proc/common.clj | 567 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/proc/host.clj | 86 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/rt.clj | 863 |
8 files changed, 3 insertions, 2381 deletions
diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj index bffedb69e..55b801745 100644 --- a/luxc/src/lux/compiler.clj +++ b/luxc/src/lux/compiler.clj @@ -6,9 +6,7 @@ (lux.compiler [core :as &&core] [io :as &&io] [parallel :as &¶llel] - [jvm :as &&jvm] - [js :as &&js] - ))) + [jvm :as &&jvm]))) (defn init! [platform resources-dirs ^String target-dir] (do (reset! &&core/!output-dir target-dir) @@ -16,9 +14,7 @@ (&&io/init-libs!) (.mkdirs (new java.io.File target-dir)) (case platform - "jvm" (&&jvm/init! resources-dirs target-dir) - "js" (&&js/init! resources-dirs target-dir)) - )) + "jvm" (&&jvm/init! resources-dirs target-dir)))) (def all-compilers &&jvm/all-compilers) @@ -32,5 +28,4 @@ (defn compile-program [platform mode program-module resources-dir source-dirs target-dir] (init! platform resources-dir target-dir) (case platform - "jvm" (&&jvm/compile-program mode program-module resources-dir source-dirs target-dir) - "js" (&&js/compile-program mode program-module resources-dir source-dirs target-dir))) + "jvm" (&&jvm/compile-program mode program-module resources-dir source-dirs target-dir))) diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj deleted file mode 100644 index dbf229fe5..000000000 --- a/luxc/src/lux/compiler/js.clj +++ /dev/null @@ -1,187 +0,0 @@ -(ns lux.compiler.js - (:refer-clojure :exclude [compile]) - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]] - [type :as &type] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &optimizer]) - [lux.optimizer :as &o] - [lux.analyser.base :as &a] - [lux.analyser.module :as &a-module] - (lux.compiler [core :as &&core] - [io :as &&io] - [parallel :as &¶llel] - [cache :as &&cache]) - (lux.compiler.js [base :as &&] - [lux :as &&lux] - [rt :as &&rt] - [cache :as &&js-cache]) - (lux.compiler.js.proc [common :as &&common] - [host :as &&host]) - ) - (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory - NashornScriptEngine - ScriptObjectMirror) - (jdk.nashorn.internal.runtime Undefined)) - ) - -;; [Resources] -(defn ^:private compile-expression [syntax] - (|let [[[?type [_file-name _line _]] ?form] syntax] - (|case ?form - (&o/$bool ?value) - (&&lux/compile-bool ?value) - - (&o/$nat ?value) - (&&lux/compile-nat ?value) - - (&o/$int ?value) - (&&lux/compile-int ?value) - - (&o/$deg ?value) - (&&lux/compile-deg ?value) - - (&o/$frac ?value) - (&&lux/compile-frac ?value) - - (&o/$text ?value) - (&&lux/compile-text ?value) - - (&o/$tuple ?elems) - (&&lux/compile-tuple compile-expression ?elems) - - (&o/$var (&/$Local ?idx)) - (&&lux/compile-local compile-expression ?idx) - - (&o/$captured ?scope ?captured-id ?source) - (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) - - (&o/$def ?module ?name) - (&&lux/compile-global ?module ?name) - - (&o/$apply ?fn ?args) - (&&lux/compile-apply compile-expression ?fn ?args) - - (&o/$loop _register-offset _inits _body) - (&&lux/compile-loop compile-expression _register-offset _inits _body) - - (&o/$iter _register-offset ?args) - (&&lux/compile-iter compile-expression _register-offset ?args) - - (&o/$variant ?tag ?tail ?members) - (&&lux/compile-variant compile-expression ?tag ?tail ?members) - - (&o/$case ?value [?pm ?bodies]) - (&&lux/compile-case compile-expression ?value ?pm ?bodies) - - (&o/$let _value _register _body) - (&&lux/compile-let compile-expression _value _register _body) - - (&o/$record-get _value _path) - (&&lux/compile-record-get compile-expression _value _path) - - (&o/$if _test _then _else) - (&&lux/compile-if compile-expression _test _then _else) - - (&o/$function _register-offset ?arity ?scope ?env ?body) - (&&lux/compile-function compile-expression ?arity ?scope ?env ?body) - - (&o/$ann ?value-ex ?type-ex) - (compile-expression ?value-ex) - - (&o/$proc [?proc-category ?proc-name] ?args special-args) - (case ?proc-category - "js" (&&host/compile-proc compile-expression ?proc-name ?args special-args) - ;; common - (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) - - _ - (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) - )) - -(defn init! - "(-> (List Text) Null)" - [resources-dirs ^String target-dir] - nil) - -(defn eval! [expr] - (&/with-eval - (|do [compiled-expr (compile-expression expr) - js-output (&&/run-js! compiled-expr)] - (return (&&/js-to-lux js-output))))) - -(def all-compilers - (&/T [(partial &&lux/compile-def compile-expression) - (partial &&lux/compile-program compile-expression) - (fn [^ScriptObjectMirror macro args state] - (&&/js-to-lux (.call macro nil (to-array [(&&/wrap-lux-obj args) - (&&/wrap-lux-obj state)]))))])) - -(defn compile-module [source-dirs name] - (|do [[file-name file-content] (&&io/read-file source-dirs name) - :let [file-hash (hash file-content) - compile-module!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] - (&/|eitherL (|do [output (&&cache/load name) - ^StringBuilder total-buffer &&/get-total-buffer - :let [module-code-path (str @&&core/!output-dir java.io.File/separator name java.io.File/separator &&/module-js-name) - _ (.append total-buffer ^String (str (slurp module-code-path) "\n"))]] - (return output)) - (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc (str "[Compiler Error] Cannot re-define a module: " name)) - (|do [_ (&&cache/delete name) - _ (&&/init-buffer) - _ (&a-module/create-module name file-hash) - _ (&a-module/flag-active-module name) - _ (if (= "lux" name) - &&rt/compile-LuxRT - (return nil))] - (fn [state] - (|case ((&/exhaust% compiler-step) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [_ (&a-module/flag-compiled-module name) - _ &&/save-module-js! - module-descriptor (&&core/generate-module-descriptor file-hash) - _ (&&core/write-module-descriptor! name module-descriptor)] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message))))))))) - ) - -(let [!err! *err*] - (defn compile-program [mode program-module resources-dir source-dirs target-dir] - (do (init! resources-dir target-dir) - (let [m-action (|do [_ (&&/run-js! "var console = { log: print };") - _ (&&cache/pre-load-cache! source-dirs - &&js-cache/load-def-value - &&js-cache/install-all-defs-in-module - &&js-cache/uninstall-all-defs-in-module) - _ (compile-module source-dirs "lux") - _ (compile-module source-dirs program-module) - ^StringBuilder total-buffer &&/get-total-buffer - :let [full-program-file (str @&&core/!output-dir java.io.File/separator "program.js") - _ (&&core/write-file full-program-file (.getBytes (.toString total-buffer)))]] - (return nil))] - (|case (m-action (&/init-state "JS" mode (&&/js-host))) - (&/$Right ?state _) - (do (println "Compilation complete!") - (&&cache/clean ?state)) - - (&/$Left ?message) - (binding [*out* !err!] - (do (println (str "Compilation failed:\n" ?message)) - (flush) - (System/exit 1) - )) - ))))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj deleted file mode 100644 index 7f560b87d..000000000 --- a/luxc/src/lux/compiler/js/base.clj +++ /dev/null @@ -1,243 +0,0 @@ -(ns lux.compiler.js.base - (:refer-clojure :exclude [compile]) - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [deftuple |let |do return* return |case]] - [host :as &host]) - [lux.compiler.core :as &&] - ) - (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory - NashornScriptEngine - ScriptObjectMirror - JSObject) - (jdk.nashorn.internal.runtime Undefined) - (java.io File - BufferedOutputStream - FileOutputStream)) - ) - -(deftuple - ["interpreter" - "buffer" - "total-buffer"]) - -(defn js-host [] - (&/$Js (&/T [;; "interpreter" - (.getScriptEngine (new NashornScriptEngineFactory)) - ;; "buffer" - &/$None - ;; "total-buffer" - (new StringBuilder) - ]))) - -(def ^String module-js-name "module.js") - -(defn init-buffer [] - (&/change-js-host-slot $buffer (fn [_] (&/$Some (new StringBuilder))))) - -(def get-buffer - (|do [host &/js-host] - (|case (&/get$ $buffer host) - (&/$Some _buffer) - (return _buffer) - - (&/$None) - (&/fail-with-loc "[Error] No buffer available.")))) - -(def get-total-buffer - (|do [host &/js-host] - (return (&/get$ $total-buffer host)))) - -(defn run-js! [^String js-code] - (|do [host &/js-host - :let [interpreter ^NashornScriptEngine (&/get$ $interpreter host)]] - (try (return (.eval interpreter js-code)) - (catch Exception ex - (&/fail-with-loc (str ex)))))) - -(def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) - -(defn ^:private _slice_ [wrap-lux-obj ^"[Ljava.lang.Object;" value] - (reify JSObject - (isFunction [self] true) - (call [self this args] - (let [slice (java.util.Arrays/copyOfRange value ^int (aget args 0) ^int (alength value))] - (wrap-lux-obj slice))))) - -(defn ^:private _toString_ [obj] - (reify JSObject - (isFunction [self] true) - (call [self this args] - (&/adt->text obj) - ))) - -(defn ^:private _toString_simple [^String obj] - (reify JSObject - (isFunction [self] true) - (call [self this args] - obj - ))) - -(def ^:private i64-mask (dec (bit-shift-left 1 32))) -(deftype I64 [value] - JSObject - (getMember [self member] - (condp = member - "H" (-> value (bit-shift-right 32) int) - "L" (-> value (bit-and i64-mask) (bit-shift-left 32) (bit-shift-right 32) int) - ;; else - (assert false (str "I64#getMember = " member))))) - -(deftype EncChar [value] - JSObject - (getMember [self member] - (condp = member - "C" value - ;; "toString" (_toString_simple value) - ;; else - (assert false (str "EncChar#getMember = " member))))) - -(deftype LuxJsObject [^"[Ljava.lang.Object;" obj] - JSObject - (isFunction [self] false) - (getSlot [self idx] - (let [value (aget obj idx)] - (cond (instance? lux-obj-class value) - (new LuxJsObject value) - - (instance? java.lang.Long value) - (new I64 value) - - (instance? java.lang.Character value) - (new EncChar (str value)) - - :else - value))) - (getMember [self member] - (condp = member - "toString" (_toString_ obj) - "length" (alength obj) - "slice" (_slice_ #(new LuxJsObject %) obj) - ;; else - (assert false (str "wrap-lux-obj#getMember = " member))))) - -(defn wrap-lux-obj [obj] - (if (instance? lux-obj-class obj) - (new LuxJsObject obj) - obj)) - -(defn ^:private int64? [^ScriptObjectMirror js-object] - (and (.hasMember js-object "H") - (.hasMember js-object "L"))) - -(defn ^:private encoded-char? [^ScriptObjectMirror js-object] - (.hasMember js-object "C")) - -(defn ^:private decode-char [^ScriptObjectMirror js-object] - (-> ^String (.getMember js-object "C") - (.charAt 0))) - -(defn ^:private parse-int64 [^ScriptObjectMirror js-object] - (+ (-> (.getMember js-object "H") - long - (bit-shift-left 32)) - (-> (.getMember js-object "L") - long))) - -(defn js-to-lux [js-object] - (cond (or (nil? js-object) - (instance? java.lang.Boolean js-object) - (instance? java.lang.Integer js-object) - (instance? java.lang.String js-object)) - js-object - - (instance? java.lang.Number js-object) - (double js-object) - - (instance? LuxJsObject js-object) - (.-obj ^LuxJsObject js-object) - - (instance? I64 js-object) - (.-value ^I64 js-object) - - (instance? EncChar js-object) - (.charAt ^String (.-value ^EncChar js-object) 0) - - ;; (instance? Undefined js-object) - ;; (assert false "UNDEFINED") - - (instance? ScriptObjectMirror js-object) - (let [^ScriptObjectMirror js-object js-object] - (cond (.isArray js-object) - (let [array-vec (loop [num-keys (.size js-object) - idx 0 - array-vec []] - (if (< idx num-keys) - (let [idx-key (str idx)] - (if (.hasMember js-object idx-key) - (recur num-keys - (inc idx) - (conj array-vec (js-to-lux (.getMember js-object idx-key)))) - (recur (inc num-keys) - (inc idx) - (conj array-vec nil)))) - array-vec))] - (&/T array-vec)) - - (.isFunction js-object) - js-object - - (int64? js-object) - (parse-int64 js-object) - - (encoded-char? js-object) - (decode-char js-object) - - :else - js-object - ;; (assert false (str "Unknown kind of JS object: " js-object)) - )) - - :else - (assert false (str "Unknown kind of JS object: " (class js-object) " :: " js-object)))) - -(defn run-js!+ [^String js-code] - (|do [raw (run-js! js-code)] - (return (js-to-lux raw)))) - -(def ^String unit (pr-str &/unit-tag)) - -(defn save-js! [name ^String script] - (|do [_ (run-js! script) - eval? &/get-eval - module &/get-module-name - ^StringBuilder buffer get-buffer - :let [_ (when (not eval?) - (.append buffer ^String (str script "\n")))]] - (return nil))) - -(def save-module-js! - (|do [eval? &/get-eval - module &/get-module-name - ^StringBuilder buffer get-buffer - ^StringBuilder total-buffer get-total-buffer - :let [buffer-code (.toString buffer) - _ (.append total-buffer ^String (str buffer-code "\n"))] - :let [_ (when (not eval?) - (let [^String module* (&host/->module-class module) - module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] - (do (.mkdirs (File. module-dir)) - (&&/write-file (str module-dir java.io.File/separator module-js-name) - (.getBytes buffer-code)))))]] - (return nil))) - -(defn js-module [module] - (-> module - (string/replace "/" "$") - (string/replace "-" "_"))) - -(defn js-var-name [module name] - (str (js-module module) "$" (&host/def-name name))) diff --git a/luxc/src/lux/compiler/js/cache.clj b/luxc/src/lux/compiler/js/cache.clj deleted file mode 100644 index 0945e6b5b..000000000 --- a/luxc/src/lux/compiler/js/cache.clj +++ /dev/null @@ -1,40 +0,0 @@ -(ns lux.compiler.js.cache - (:refer-clojure :exclude [load]) - (:require [clojure.string :as string] - [clojure.java.io :as io] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module] - [meta :as &a-meta]) - (lux.compiler [core :as &&core] - [io :as &&io]) - (lux.compiler.js [base :as &&])) - (:import (java.io File))) - -;; [Utils] -(defn ^:private read-file [^File file] - "(-> File (Array Byte))" - (with-open [reader (io/input-stream file)] - (let [length (.length file) - buffer (byte-array length)] - (.read reader buffer 0 length) - buffer))) - -;; [Resources] -(defn load-def-value [module name] - (&&/run-js!+ (&&/js-var-name module name))) - -(defn install-all-defs-in-module [module-name] - (|do [:let [module-code-path (str @&&core/!output-dir java.io.File/separator module-name java.io.File/separator &&/module-js-name) - ^bytes module-code (read-file (new File module-code-path))] - _ (&&/run-js!+ (new String module-code))] - (return (&/|list)))) - -(defn uninstall-all-defs-in-module [module-name] - (|do [] - (return nil))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj deleted file mode 100644 index ae3a6425c..000000000 --- a/luxc/src/lux/compiler/js/lux.clj +++ /dev/null @@ -1,387 +0,0 @@ -(ns lux.compiler.js.lux - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - (lux.analyser [base :as &a] - [module :as &a-module] - [meta :as &a-meta]) - (lux.compiler.js [base :as &&] - [rt :as &&rt]) - )) - -;; [Utils] -(defn ^:private captured-name [register] - (str "$" register)) - -(defn ^:private register-name [register] - (str "_" register)) - -;; [Exports] -(defn compile-bool [?value] - (return (str ?value))) - -(def mask-4b (dec (bit-shift-left 1 32))) - -(do-template [<name>] - (defn <name> [value] - (let [high (-> value (bit-shift-right 32) int) - low (-> value (bit-and mask-4b) (bit-shift-left 32) (bit-shift-right 32) int)] - (return (str "LuxRT$makeI64" "(" high "," low ")")))) - - compile-nat - compile-int - compile-deg - ) - -(defn compile-frac [value] - (return (str value))) - -(defn compile-char [value] - (return (str "{C:" (pr-str (str value)) "}"))) - -(defn compile-text [?value] - (return (pr-str ?value))) - -(defn compile-tuple [compile ?elems] - (|do [:let [num-elems (&/|length ?elems)]] - (|case num-elems - 0 - (return &&/unit) - - 1 - (compile (&/|head ?elems)) - - _ - (|do [=elems (&/map% compile ?elems)] - (return (str "[" (->> =elems (&/|interpose ",") (&/fold str "")) "]")))))) - -(defn compile-variant [compile tag tail? value] - (|do [value-expr (compile value)] - (return (str "[" tag - "," (if tail? "\"\"" "null") - "," value-expr - "]")))) - -(defn compile-local [compile register] - (return (register-name register))) - -(defn compile-captured [compile ?scope ?captured-id ?source] - (return (captured-name ?captured-id))) - -(defn compile-global [module name] - (return (&&/js-var-name module name))) - -(defn compile-apply [compile ?fn ?args] - (|do [=fn (compile ?fn) - =args (&/map% compile ?args)] - (return (str =fn "(" (->> =args (&/|interpose ",") (&/fold str "")) ")")))) - -(defn compile-loop [compile register-offset inits body] - (|do [:let [registers (&/|map #(->> % (+ register-offset) register-name) - (&/|range* 0 (dec (&/|length inits))))] - register-inits (&/map% compile inits) - =body (compile body)] - (return (str "(function _loop(" (->> registers (&/|interpose ",") (&/fold str "")) ") {" - (str "return " =body ";") - "})(" (->> register-inits (&/|interpose ",") (&/fold str "")) ")")) - )) - -(defn compile-iter [compile register-offset ?args] - ;; Can only optimize if it is a simple expression. - ;; Will not work if it's inside an 'if', unlike on the JVM. - ;; (|do [[updates _] (&/fold% (fn [updates+offset ?arg] - ;; (|let [[updates offset] updates+offset - ;; already-set? (|case ?arg - ;; [_ (&o/$var (&/$Local l-idx))] - ;; (= offset l-idx) - - ;; _ - ;; false)] - ;; (if already-set? - ;; (return (&/T [updates (inc offset)])) - ;; (|do [=arg (compile ?arg)] - ;; (return (&/T [(str updates - ;; (register-name offset) " = " =arg ";") - ;; (inc offset)])))))) - ;; (&/T ["" register-offset]) - ;; ?args)] - ;; (return updates)) - (|do [=args (&/map% compile ?args)] - (return (str "_loop(" - (->> =args (&/|interpose ",") (&/fold str "")) - ")"))) - ) - -(defn compile-let [compile _value _register _body] - (|do [=value (compile _value) - =body (compile _body)] - (return (str "(function() {" - "var " (register-name _register) " = " =value ";" - " return " =body - ";})()")))) - -(defn compile-record-get [compile _value _path] - (|do [=value (compile _value)] - (return (&/fold (fn [source step] - (|let [[idx tail?] step - method (if tail? "product_getRight" "product_getLeft")] - (str "LuxRT$" method "(" source "," idx ")"))) - (str "(" =value ")") - _path)))) - -(defn compile-if [compile _test _then _else] - (|do [=test (compile _test) - =then (compile _then) - =else (compile _else)] - (return (str "(" =test " ? " =then " : " =else ")")))) - -(def ^:private savepoint "pm_cursor_savepoint") -(def ^:private cursor "pm_cursor") -(defn ^:private cursor-push [value] - (str cursor ".push(" value ");")) -(def ^:private cursor-save (str savepoint ".push(" cursor ".slice());")) -(def ^:private cursor-restore (str cursor " = " savepoint ".pop();")) -(def ^:private cursor-peek (str cursor "[" cursor ".length - 1]")) -(def ^:private cursor-pop (str cursor ".pop();")) -(def ^:private pm-error (.intern (pr-str (str (char 0) "PM-ERROR" (char 0))))) -(def ^:private pm-fail (str "throw " pm-error ";")) - -(defn ^:private compile-pm* [compile pm bodies] - "(-> Case-Pattern (List Analysis) (Lux JS))" - (|case pm - (&o/$ExecPM _body-idx) - (|case (&/|at _body-idx bodies) - (&/$Some body) - (|do [=body (compile body)] - (return (str "return " =body ";"))) - - (&/$None) - (assert false)) - - (&o/$PopPM) - (return cursor-pop) - - (&o/$BindPM _register) - (return (str "var " (register-name _register) " = " cursor-peek ";" - cursor-pop)) - - (&o/$BoolPM _value) - (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) - - (&o/$NatPM _value) - (|do [=value (compile-nat _value)] - (return (str "if(!" (str "LuxRT$eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) - - (&o/$IntPM _value) - (|do [=value (compile-int _value)] - (return (str "if(!" (str "LuxRT$eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) - - (&o/$DegPM _value) - (|do [=value (compile-deg _value)] - (return (str "if(!" (str "LuxRT$eqI64(" cursor-peek "," =value ")") ") { " pm-fail " }"))) - - (&o/$FracPM _value) - (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }")) - - (&o/$TextPM _value) - (|do [=value (compile-text _value)] - (return (str "if(" cursor-peek " !== " =value ") { " pm-fail " }"))) - - (&o/$TuplePM _idx+) - (|let [[_idx is-tail?] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [_idx true])) - getter (if is-tail? "product_getRight" "product_getLeft")] - (return (str (cursor-push (str "LuxRT$" getter "(" cursor-peek "," _idx ")"))))) - - (&o/$VariantPM _idx+) - (|let [[_idx is-last] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [_idx true])) - temp-assignment (str "temp = LuxRT$sum_get(" cursor-peek "," _idx "," (if is-last "\"\"" "null") ");")] - (return (str temp-assignment - (str "if(temp !== null) {" - (cursor-push "temp") - "}" - "else {" - pm-fail - "}")))) - - (&o/$SeqPM _left-pm _right-pm) - (|do [=left (compile-pm* compile _left-pm bodies) - =right (compile-pm* compile _right-pm bodies)] - (return (str =left =right))) - - (&o/$AltPM _left-pm _right-pm) - (|do [=left (compile-pm* compile _left-pm bodies) - =right (compile-pm* compile _right-pm bodies)] - (return (str "try {" - cursor-save - =left - "}" - "catch(ex) {" - "if(ex === " pm-error ") {" - cursor-restore - =right - "}" - "else {" - "throw ex;" - "}" - "}"))) - )) - -(defn ^:private compile-pm [compile pm bodies] - (|do [raw (compile-pm* compile pm bodies)] - (return (str "try {" raw "}" - "catch(ex) {" - "if(ex === " pm-error ") {" - "throw \"Invalid expression for pattern-matching.\";" - "}" - "else {" - "throw ex;" - "}" - "}")))) - -;; [Resources] -(defn compile-case [compile ?value ?pm ?bodies] - (|do [=value (compile ?value) - =pm (compile-pm compile ?pm ?bodies)] - (return (str "(function() {" - "\"use strict\";" - "var temp;" - "var " cursor " = [" =value "];" - "var " savepoint " = [];" - =pm - "})()")))) - -(defn compile-function [compile arity ?scope ?env ?body] - (|do [:let [??scope (&/|reverse ?scope) - function-name (str (&&/js-module (&/|head ??scope)) - "$" (&host/location (&/|tail ??scope))) - func-args (->> (&/|range* 0 (dec arity)) - (&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];"))) - (&/fold str ""))] - =env-vars (&/map% (fn [=captured] - (|case =captured - [_ (&o/$captured ?scope ?captured-id ?source)] - (return (captured-name ?captured-id)))) - (&/|vals ?env)) - =env-values (&/map% (fn [=captured] - (|case =captured - [_ (&o/$captured ?scope ?captured-id ?source)] - (compile ?source))) - (&/|vals ?env)) - =body (compile ?body)] - (return (str "(function(" (->> =env-vars (&/|interpose ",") (&/fold str "")) ") {" - "return " - (str "(function " function-name "() {" - "\"use strict\";" - "var num_args = arguments.length;" - "if(num_args == " arity ") {" - (str "var " (register-name 0) " = " function-name ";") - (str "var _loop = " function-name ";") - func-args - (str "while(true) {" - "return " =body ";" - "}") - "}" - "else if(num_args > " arity ") {" - "return " function-name ".apply(null, [].slice.call(arguments,0," arity "))" - ".apply(null, [].slice.call(arguments," arity "));" - "}" - ;; Less than arity - "else {" - "var curried = [].slice.call(arguments);" - "return function() { " - "return " function-name ".apply(null, curried.concat([].slice.call(arguments)));" - " };" - "}" - "})") - ";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")")))) - -(defn compile-def [compile ?name ?body def-meta] - (|do [module-name &/get-module-name] - (|case (&a-meta/meta-get &a-meta/alias-tag def-meta) - (&/$Some [_ (&/$Symbol [r-module r-name])]) - (if (= 1 (&/|length def-meta)) - (|do [def-value (&&/run-js! (&&/js-var-name r-module r-name)) - def-type (&a-module/def-type r-module r-name) - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value))] - (return nil)) - (&/fail-with-loc (str "[Compilation Error] Aliases cannot contain meta-data: " (str module-name &/+name-separator+ ?name)))) - - (&/$Some _) - (&/fail-with-loc "[Compilation Error] Invalid syntax for lux;alias meta-data. Must be an Ident.") - - _ - (|do [:let [var-name (&&/js-var-name module-name ?name)] - =body (compile ?body) - :let [def-js (str "var " var-name " = " =body ";") - is-type? (|case (&a-meta/meta-get &a-meta/type?-tag def-meta) - (&/$Some [_ (&/$Bool true)]) - true - - _ - false) - def-type (&a/expr-type* ?body)] - _ (&&/save-js! ?name def-js) - def-value (&&/run-js!+ var-name) - _ (&/without-repl-closure - (&a-module/define module-name ?name def-type def-meta def-value)) - _ (|case (&/T [is-type? (&a-meta/meta-get &a-meta/tags-tag def-meta)]) - [true (&/$Some [_ (&/$Tuple tags*)])] - (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag def-meta) - (&/$Some _) - true - - _ - false)] - tags (&/map% (fn [tag*] - (|case tag* - [_ (&/$Text tag)] - (return tag) - - _ - (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) - tags*) - _ (&a-module/declare-tags module-name tags was-exported? def-value)] - (return nil)) - - [false (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Cannot define tags for non-type.") - - [true (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") - - [_ (&/$None)] - (return nil)) - :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] - (return nil)) - )) - ) - -(defn compile-program [compile ?body] - (|do [=body (compile ?body) - :let [program-js (str (str "var " (register-name 0) " = LuxRT$programArgs();") - (str "(" =body ")(null);"))] - eval? &/get-eval - ^StringBuilder buffer &&/get-buffer - :let [_ (when (not eval?) - (.append buffer ^String (str program-js "\n")))]] - (return ""))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj deleted file mode 100644 index c70ea6f9e..000000000 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ /dev/null @@ -1,567 +0,0 @@ -(ns lux.compiler.js.proc.common - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [analyser :as &analyser] - [optimizer :as &o]) - [lux.analyser.base :as &a] - (lux.compiler.js [base :as &&] - [rt :as &&rt] - [lux :as &&lux]))) - -;; [Resources] -(do-template [<name> <op>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] - =input (compile ?input) - =param (compile ?param)] - (return (str "LuxRT$" <op> "(" =input "," =param ")")))) - - ^:private compile-bit-and "andI64" - ^:private compile-bit-or "orI64" - ^:private compile-bit-xor "xorI64" - ) - -(do-template [<name> <op>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] - =input (compile ?input) - =param (compile ?param)] - (return (str "LuxRT$" <op> "(" =input "," =param ".L)")))) - - ^:private compile-bit-left-shift "shlI64" - ^:private compile-bit-arithmetic-right-shift "shrI64" - ^:private compile-bit-logical-right-shift "ushrI64" - ) - -(defn ^:private compile-bit-count [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - =input (compile ?input)] - (return (str "LuxRT$countI64(" =input ")")))) - -(defn ^:private compile-lux-is [compile ?values special-args] - (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values] - =left (compile ?left) - =right (compile ?right)] - (return (str "(" =left " === " =right ")")))) - -(defn ^:private compile-lux-try [compile ?values special-args] - (|do [:let [(&/$Cons ?op (&/$Nil)) ?values] - =op (compile ?op)] - (return (str "LuxRT$runTry(" =op ")")))) - -(defn ^:private compile-array-new [compile ?values special-args] - (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] - =length (compile ?length)] - (return (str "new Array(" (str "LuxRT$toNumberI64(" =length ")") ")")))) - -(defn ^:private compile-array-get [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - =array (compile ?array) - =idx (compile ?idx)] - (return (str "LuxRT$arrayGet(" =array "," =idx ")")))) - -(defn ^:private compile-array-put [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values - ;; (&/$Nil) special-args - ] - =array (compile ?array) - =idx (compile ?idx) - =elem (compile ?elem)] - (return (str "LuxRT$arrayPut(" =array "," =idx "," =elem ")")))) - -(defn ^:private compile-array-remove [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values - ;; (&/$Nil) special-args - ] - =array (compile ?array) - =idx (compile ?idx)] - (return (str "LuxRT$arrayRemove(" =array "," =idx ")")))) - -(defn ^:private compile-array-size [compile ?values special-args] - (|do [:let [(&/$Cons ?array (&/$Nil)) ?values - ;; (&/$Nil) special-args - ] - =array (compile ?array)] - (return (str "LuxRT$fromNumberI64(" =array ".length" ")")))) - -(do-template [<name> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "LuxRT$" <method> "(" =x "," =y ")")))) - - ^:private compile-nat-add "addI64" - ^:private compile-nat-sub "subI64" - ^:private compile-nat-mul "mulI64" - ^:private compile-nat-div "divN64" - ^:private compile-nat-rem "remN64" - ^:private compile-nat-eq "eqI64" - ^:private compile-nat-lt "ltN64" - - ^:private compile-int-add "addI64" - ^:private compile-int-sub "subI64" - ^:private compile-int-mul "mulI64" - ^:private compile-int-div "divI64" - ^:private compile-int-rem "remI64" - ^:private compile-int-eq "eqI64" - ^:private compile-int-lt "ltI64" - - ^:private compile-deg-add "addI64" - ^:private compile-deg-sub "subI64" - ^:private compile-deg-mul "mulD64" - ^:private compile-deg-div "divD64" - ^:private compile-deg-rem "subI64" - ^:private compile-deg-eq "eqI64" - ^:private compile-deg-lt "ltD64" - ^:private compile-deg-scale "mulI64" - ^:private compile-deg-reciprocal "divI64" - ) - -(do-template [<name> <opcode>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x " " <opcode> " " =y ")")))) - - ^:private compile-frac-add "+" - ^:private compile-frac-sub "-" - ^:private compile-frac-mul "*" - ^:private compile-frac-div "/" - ^:private compile-frac-rem "%" - ^:private compile-frac-eq "===" - ^:private compile-frac-lt "<" - ) - -(do-template [<name> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "LuxRT$" <method> "(" =x ")")) - )) - - ^:private compile-frac-decode "decodeFrac" - ) - -(do-template [<name> <compiler> <value>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Nil) ?values]] - (<compiler> <value>))) - - ^:private compile-nat-min &&lux/compile-nat 0 - ^:private compile-nat-max &&lux/compile-nat -1 - - ^:private compile-int-min &&lux/compile-int Long/MIN_VALUE - ^:private compile-int-max &&lux/compile-int Long/MAX_VALUE - - ^:private compile-deg-min &&lux/compile-deg 0 - ^:private compile-deg-max &&lux/compile-deg -1 - - ^:private compile-frac-smallest &&lux/compile-frac Double/MIN_VALUE - ^:private compile-frac-min &&lux/compile-frac (* -1.0 Double/MAX_VALUE) - ^:private compile-frac-max &&lux/compile-frac Double/MAX_VALUE - - ^:private compile-frac-not-a-number &&lux/compile-frac "NaN" - ^:private compile-frac-positive-infinity &&lux/compile-frac "Infinity" - ^:private compile-frac-negative-infinity &&lux/compile-frac "-Infinity" - ) - -(defn ^:private compile-frac-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "(" =x ")" ".toString()")))) - -(do-template [<name>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]] - (compile ?x))) - - ^:private compile-nat-to-int - ^:private compile-int-to-nat - ) - -(defn ^:private compile-int-to-frac [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "LuxRT$toNumberI64(" =x ")")))) - -(defn ^:private compile-frac-to-int [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "LuxRT$fromNumberI64(" =x ")")))) - -(defn ^:private compile-deg-to-frac [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "LuxRT$degToFrac(" =x ")")))) - -(defn ^:private compile-frac-to-deg [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "LuxRT$fracToDeg(" =x ")")))) - -(do-template [<name> <op>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x <op> =y ")")))) - - ^:private compile-text-eq "===" - ^:private compile-text-lt "<" - ) - -(do-template [<name> <op>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str "(" =x ".C" " " <op> " " =y ".C" ")")))) - - ^:private compile-char-eq "===" - ^:private compile-char-lt "<" - ) - -(defn ^:private compile-text-concat [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] - =x (compile ?x) - =y (compile ?y)] - (return (str =x ".concat(" =y ")")))) - -(do-template [<name> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] - =text (compile ?text) - =part (compile ?part) - =start (compile ?start)] - (return (str "LuxRT$" <method> "(" =text "," =part "," =start ")")))) - - ^:private compile-text-last-index "lastIndex" - ^:private compile-text-index "index" - ) - -(defn ^:private compile-text-contains? [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] - =text (compile ?text) - =part (compile ?part)] - (return (str "(" (str (str "(" =text ")") - ".indexOf" - (str "(" =part ")")) - " !== " "-1" - ")")))) - -(defn ^:private compile-text-clip [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] - =text (compile ?text) - =from (compile ?from) - =to (compile ?to)] - (return (str "LuxRT$clip(" (str =text "," =from "," =to) ")")))) - -(defn ^:private compile-text-replace-all [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?to-find (&/$Cons ?replace-with (&/$Nil)))) ?values] - =text (compile ?text) - =to-find (compile ?to-find) - =replace-with (compile ?replace-with)] - (return (str "LuxRT$replaceAll(" (str =text "," =to-find "," =replace-with) ")")))) - -(defn ^:private compile-text-size [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - =text (compile ?text)] - (return (str "LuxRT$fromNumberI64(" =text ".length" ")")))) - -(defn ^:private compile-text-hash [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - =text (compile ?text)] - (return (str "LuxRT$textHash(" =text ")")))) - -(defn ^:private compile-text-char [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] - =text (compile ?text) - =idx (compile ?idx)] - (return (str "LuxRT$textChar(" (str =text "," =idx) ")")))) - -(defn ^:private compile-char-to-text [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "(" =x ").C")))) - -(defn ^:private compile-char-to-nat [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "LuxRT$fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) - -(defn ^:private compile-nat-to-char [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - =x (compile ?x)] - (return (str "{C:" - (str "String.fromCharCode(" - (str "LuxRT$toNumberI64(" =x ")") - ")") - "}")))) - -(defn ^:private compile-io-log [compile ?values special-args] - (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] - =message (compile ?message)] - (return (str "LuxRT$log(" =message ")")))) - -(defn ^:private compile-io-error [compile ?values special-args] - (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] - =message (compile ?message)] - (return (str "LuxRT$error(" =message ")")))) - -(defn ^:private compile-io-exit [compile ?values special-args] - (|do [:let [(&/$Cons ?code (&/$Nil)) ?values] - =code (compile ?code)] - (return (str "(process && process.exit && process.exit(LuxRT$toNumberI64(" =code ")))")))) - -(defn ^:private compile-io-current-time [compile ?values special-args] - (|do [:let [(&/$Nil) ?values]] - (return (str "LuxRT$fromNumberI64(" "(new Date()).getTime()" ")")))) - -(defn ^:private compile-atom-new [compile ?values special-args] - (|do [:let [(&/$Cons ?init (&/$Nil)) ?values] - =init (compile ?init)] - (return (str "{V: " =init "}")))) - -(defn ^:private compile-atom-get [compile ?values special-args] - (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] - =atom (compile ?atom)] - (return (str =atom ".V")))) - -(defn ^:private compile-atom-compare-and-swap [compile ?values special-args] - (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values] - =atom (compile ?atom) - =old (compile ?old) - =new (compile ?new)] - (return (str "(function() {" - (str "var atom = " =atom ";") - (str "if(" (str "(atom.V === " =old ")") ") {" - (str "atom.V = " =new ";") - "return true;" - "}" - "else {" - "return false;" - "}") - "})()")))) - -(defn ^:private compile-process-concurrency-level [compile ?values special-args] - (|do [:let [(&/$Nil) ?values]] - (return (str "LuxRT$ONE")))) - -(defn ^:private compile-process-future [compile ?values special-args] - (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values] - =procedure (compile ?procedure)] - (return (str "setTimeout(" - (str "function() {" =procedure "(null)" "}") - ",0)")))) - -(defn ^:private compile-process-schedule [compile ?values special-args] - (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values] - =milliseconds (compile ?milliseconds) - =procedure (compile ?procedure)] - (return (str "setTimeout(" - (str "function() {" =procedure "(null)" "}") - "," - (str "LuxRT$toNumberI64(" =milliseconds ")") - ")")))) - -(do-template [<name> <field>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Nil) ?values]] - (return (str "Math." <field>)))) - - ^:private compile-math-e "E" - ^:private compile-math-pi "PI" - ) - -(do-template [<name> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] - =input (compile ?input)] - (return (str "Math." <method> "(" =input ")")))) - - ^:private compile-math-cos "cos" - ^:private compile-math-sin "sin" - ^:private compile-math-tan "tan" - ^:private compile-math-acos "acos" - ^:private compile-math-asin "asin" - ^:private compile-math-atan "atan" - ^:private compile-math-exp "exp" - ^:private compile-math-log "log" - ^:private compile-math-ceil "ceil" - ^:private compile-math-floor "floor" - ) - -(do-template [<name> <method>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] - =input (compile ?input) - =param (compile ?param)] - (return (str "Math." <method> "(" =input "," =param ")")))) - - ^:private compile-math-pow "pow" - ) - -(defn compile-proc [compile category proc ?values special-args] - (case category - "lux" - (case proc - "is" (compile-lux-is compile ?values special-args) - "try" (compile-lux-try compile ?values special-args)) - - "io" - (case proc - "log" (compile-io-log compile ?values special-args) - "error" (compile-io-error compile ?values special-args) - "exit" (compile-io-exit compile ?values special-args) - "current-time" (compile-io-current-time compile ?values special-args)) - - "text" - (case proc - "=" (compile-text-eq compile ?values special-args) - "<" (compile-text-lt compile ?values special-args) - "concat" (compile-text-concat compile ?values special-args) - "clip" (compile-text-clip compile ?values special-args) - "index" (compile-text-index compile ?values special-args) - "last-index" (compile-text-last-index compile ?values special-args) - "size" (compile-text-size compile ?values special-args) - "hash" (compile-text-hash compile ?values special-args) - "replace-all" (compile-text-replace-all compile ?values special-args) - "char" (compile-text-char compile ?values special-args) - "contains?" (compile-text-contains? compile ?values special-args) - ) - - "bit" - (case proc - "count" (compile-bit-count compile ?values special-args) - "and" (compile-bit-and compile ?values special-args) - "or" (compile-bit-or compile ?values special-args) - "xor" (compile-bit-xor compile ?values special-args) - "left-shift" (compile-bit-left-shift compile ?values special-args) - "arithmetic-right-shift" (compile-bit-arithmetic-right-shift compile ?values special-args) - "logical-right-shift" (compile-bit-logical-right-shift compile ?values special-args)) - - "array" - (case proc - "new" (compile-array-new compile ?values special-args) - "get" (compile-array-get compile ?values special-args) - "put" (compile-array-put compile ?values special-args) - "remove" (compile-array-remove compile ?values special-args) - "size" (compile-array-size compile ?values special-args)) - - "nat" - (case proc - "+" (compile-nat-add compile ?values special-args) - "-" (compile-nat-sub compile ?values special-args) - "*" (compile-nat-mul compile ?values special-args) - "/" (compile-nat-div compile ?values special-args) - "%" (compile-nat-rem compile ?values special-args) - "=" (compile-nat-eq compile ?values special-args) - "<" (compile-nat-lt compile ?values special-args) - "max" (compile-nat-max compile ?values special-args) - "min" (compile-nat-min compile ?values special-args) - "to-int" (compile-nat-to-int compile ?values special-args) - "to-char" (compile-nat-to-char compile ?values special-args) - ) - - "int" - (case proc - "+" (compile-int-add compile ?values special-args) - "-" (compile-int-sub compile ?values special-args) - "*" (compile-int-mul compile ?values special-args) - "/" (compile-int-div compile ?values special-args) - "%" (compile-int-rem compile ?values special-args) - "=" (compile-int-eq compile ?values special-args) - "<" (compile-int-lt compile ?values special-args) - "max" (compile-int-max compile ?values special-args) - "min" (compile-int-min compile ?values special-args) - "to-nat" (compile-int-to-nat compile ?values special-args) - "to-frac" (compile-int-to-frac compile ?values special-args) - ) - - "deg" - (case proc - "+" (compile-deg-add compile ?values special-args) - "-" (compile-deg-sub compile ?values special-args) - "*" (compile-deg-mul compile ?values special-args) - "/" (compile-deg-div compile ?values special-args) - "%" (compile-deg-rem compile ?values special-args) - "=" (compile-deg-eq compile ?values special-args) - "<" (compile-deg-lt compile ?values special-args) - "max" (compile-deg-max compile ?values special-args) - "min" (compile-deg-min compile ?values special-args) - "to-frac" (compile-deg-to-frac compile ?values special-args) - "scale" (compile-deg-scale compile ?values special-args) - "reciprocal" (compile-deg-reciprocal compile ?values special-args) - ) - - "frac" - (case proc - "+" (compile-frac-add compile ?values special-args) - "-" (compile-frac-sub compile ?values special-args) - "*" (compile-frac-mul compile ?values special-args) - "/" (compile-frac-div compile ?values special-args) - "%" (compile-frac-rem compile ?values special-args) - "=" (compile-frac-eq compile ?values special-args) - "<" (compile-frac-lt compile ?values special-args) - "encode" (compile-frac-encode compile ?values special-args) - "decode" (compile-frac-decode compile ?values special-args) - "smallest" (compile-frac-smallest compile ?values special-args) - "max" (compile-frac-max compile ?values special-args) - "min" (compile-frac-min compile ?values special-args) - "not-a-number" (compile-frac-not-a-number compile ?values special-args) - "positive-infinity" (compile-frac-positive-infinity compile ?values special-args) - "negative-infinity" (compile-frac-negative-infinity compile ?values special-args) - "to-deg" (compile-frac-to-deg compile ?values special-args) - "to-int" (compile-frac-to-int compile ?values special-args) - ) - - "char" - (case proc - "=" (compile-char-eq compile ?values special-args) - "<" (compile-char-lt compile ?values special-args) - "to-text" (compile-char-to-text compile ?values special-args) - "to-nat" (compile-char-to-nat compile ?values special-args) - ) - - "math" - (case proc - "e" (compile-math-e compile ?values special-args) - "pi" (compile-math-pi compile ?values special-args) - "cos" (compile-math-cos compile ?values special-args) - "sin" (compile-math-sin compile ?values special-args) - "tan" (compile-math-tan compile ?values special-args) - "acos" (compile-math-acos compile ?values special-args) - "asin" (compile-math-asin compile ?values special-args) - "atan" (compile-math-atan compile ?values special-args) - "exp" (compile-math-exp compile ?values special-args) - "log" (compile-math-log compile ?values special-args) - "ceil" (compile-math-ceil compile ?values special-args) - "floor" (compile-math-floor compile ?values special-args) - "pow" (compile-math-pow compile ?values special-args) - ) - - "atom" - (case proc - "new" (compile-atom-new compile ?values special-args) - "get" (compile-atom-get compile ?values special-args) - "compare-and-swap" (compile-atom-compare-and-swap compile ?values special-args) - ) - - "process" - (case proc - "concurrency-level" (compile-process-concurrency-level compile ?values special-args) - "future" (compile-process-future compile ?values special-args) - "schedule" (compile-process-schedule compile ?values special-args) - ) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/js/proc/host.clj b/luxc/src/lux/compiler/js/proc/host.clj deleted file mode 100644 index 39bdb99c1..000000000 --- a/luxc/src/lux/compiler/js/proc/host.clj +++ /dev/null @@ -1,86 +0,0 @@ -(ns lux.compiler.js.proc.host - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]]))) - -(defn ^:private compile-js-ref [compile ?values special-args] - (|do [:let [(&/$Cons ?name (&/$Nil)) special-args]] - (return ?name))) - -(defn ^:private compile-js-new [compile ?values special-args] - (|do [:let [(&/$Cons ?function ?args) ?values] - =function (compile ?function) - =args (&/map% compile ?args)] - (return (str "new (" =function ")(" - (->> =args - (&/|interpose ",") - (&/fold str "")) - ")")))) - -(defn ^:private compile-js-call [compile ?values special-args] - (|do [:let [(&/$Cons ?function ?args) ?values] - =function (compile ?function) - =args (&/map% compile ?args)] - (return (str "(" =function ")(" - (->> =args - (&/|interpose ",") - (&/fold str "")) - ")")))) - -(defn ^:private compile-js-object-call [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values] - =object (compile ?object) - =field (compile ?field) - =args (&/map% compile ?args)] - (return (str "LuxRT$" "jsObjectCall" - "(" =object - "," =field - "," (str "[" (->> =args (&/|interpose ",") (&/fold str "")) "]") - ")")))) - -(defn ^:private compile-js-object [compile ?values special-args] - (|do [:let [(&/$Nil) ?values]] - (return "{}"))) - -(defn ^:private compile-js-get-field [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] - =object (compile ?object) - =field (compile ?field)] - (return (str "(" =object ")" "[" =field "]")))) - -(defn ^:private compile-js-set-field [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?input (&/$Nil)))) ?values] - =object (compile ?object) - =field (compile ?field) - =input (compile ?input)] - (return (str "LuxRT$" "jsSetField" "(" =object "," =field "," =input ")")))) - -(defn ^:private compile-js-delete-field [compile ?values special-args] - (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values] - =object (compile ?object) - =field (compile ?field)] - (return (str "LuxRT$" "jsDeleteField" "(" =object "," =field ")")))) - -(do-template [<name> <value>] - (defn <name> [compile ?values special-args] - (return <value>)) - - ^:private compile-js-null "null" - ^:private compile-js-undefined "undefined" - ) - -(defn compile-proc [compile proc-name ?values special-args] - (case proc-name - "new" (compile-js-new compile ?values special-args) - "call" (compile-js-call compile ?values special-args) - "object-call" (compile-js-object-call compile ?values special-args) - "ref" (compile-js-ref compile ?values special-args) - "object" (compile-js-object compile ?values special-args) - "get-field" (compile-js-get-field compile ?values special-args) - "set-field" (compile-js-set-field compile ?values special-args) - "delete-field" (compile-js-delete-field compile ?values special-args) - "null" (compile-js-null compile ?values special-args) - "undefined" (compile-js-undefined compile ?values special-args) - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["js" proc-name])))) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj deleted file mode 100644 index 04ee6fc69..000000000 --- a/luxc/src/lux/compiler/js/rt.clj +++ /dev/null @@ -1,863 +0,0 @@ -(ns lux.compiler.js.rt - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.analyser.base :as &a] - [lux.compiler.js.base :as &&])) - -(def ^:private const-none (str "[0,null," &&/unit "]")) -(defn ^:private make-some [value] - (str "[1,''," value "]")) - -(def ^:private adt-methods - {"product_getLeft" (str "(function LuxRT$product_getLeft(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ;; No need for recursion - "return product[index];" - "}" - "else {" - ;; Needs recursion - "return LuxRT$product_getLeft(product[product.length - 1], (index_min_length - product.length));" - "}" - "})") - "product_getRight" (str "(function LuxRT$product_getRight(product,index) {" - "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ;; Last element. - "return product[index];" - "}" - "else if(product.length < index_min_length) {" - ;; Needs recursion - "return LuxRT$product_getRight(product[product.length - 1], (index_min_length - product.length));" - "}" - "else {" - ;; Must slice - "return product.slice(index);" - "}" - "})") - "sum_get" (let [no-match "return null;" - extact-match "return sum[2];" - recursion-test (str (str "if(sum[1] === '') {" - ;; Must recurse. - "return LuxRT$sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - "else { " no-match " }"))] - (str "(function LuxRT$sum_get(sum,wantedTag,wantsLast) {" - "if(wantedTag === sum[0]) {" - (str "if(sum[1] === wantsLast) {" extact-match "}" - "else {" recursion-test "}") - "}" - (str "else if(wantedTag > sum[0]) {" recursion-test "}") - (str "else if(wantedTag < sum[0] && wantsLast === '') {" - "return [(sum[0]-wantedTag),sum[1],sum[2]];" - "}") - "else { " no-match " }" - "})")) - }) - -(def ^:private i64-methods - {"TWO_PWR_16" "(1 << 16)" - "TWO_PWR_32" "((1 << 16) * (1 << 16))" - "TWO_PWR_64" "(((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16)))" - "TWO_PWR_63" "((((1 << 16) * (1 << 16)) * ((1 << 16) * (1 << 16))) / 2)" - "getLowBitsUnsigned" (str "(function LuxRT$getLowBitsUnsigned(i64) {" - "return (i64.L >= 0) ? i64.L : (LuxRT$TWO_PWR_32 + i64.L);" - "})") - "toNumberI64" (str "(function LuxRT$toNumberI64(i64) {" - "return (i64.H * LuxRT$TWO_PWR_32) + LuxRT$getLowBitsUnsigned(i64);" - "})") - "fromNumberI64" (str "(function LuxRT$fromNumberI64(num) {" - (str "if(isNaN(num)) {" - "return LuxRT$ZERO;" - "}") - (str "else if(num <= -LuxRT$TWO_PWR_63) {" - "return LuxRT$MIN_VALUE_I64;" - "}") - (str "else if((num + 1) >= LuxRT$TWO_PWR_63) {" - "return LuxRT$MAX_VALUE_I64;" - "}") - (str "else if(num < 0) {" - "return LuxRT$negateI64(LuxRT$fromNumberI64(-num));" - "}") - (str "else {" - "return LuxRT$makeI64((num / LuxRT$TWO_PWR_32), (num % LuxRT$TWO_PWR_32));" - "}") - "})") - "makeI64" (str "(function LuxRT$makeI64(high,low) {" - "return { H: (high|0), L: (low|0)};" - "})") - "MIN_VALUE_I64" "{ H: (0x80000000|0), L: (0|0)}" - "MAX_VALUE_I64" "{ H: (0x7FFFFFFF|0), L: (0xFFFFFFFF|0)}" - "ONE" "{ H: (0|0), L: (1|0)}" - "ZERO" "{ H: (0|0), L: (0|0)}" - "notI64" (str "(function LuxRT$notI64(i64) {" - "return LuxRT$makeI64(~i64.H,~i64.L);" - "})") - "negateI64" (str "(function LuxRT$negateI64(i64) {" - (str "if(LuxRT$eqI64(LuxRT$MIN_VALUE_I64,i64)) {" - "return LuxRT$MIN_VALUE_I64;" - "}") - (str "else {" - "return LuxRT$addI64(LuxRT$notI64(i64),LuxRT$ONE);" - "}") - "})") - "eqI64" (str "(function LuxRT$eqI64(l,r) {" - "return (l.H === r.H) && (l.L === r.L);" - "})") - "addI64" (str "(function LuxRT$addI64(l,r) {" - "var l48 = l.H >>> 16;" - "var l32 = l.H & 0xFFFF;" - "var l16 = l.L >>> 16;" - "var l00 = l.L & 0xFFFF;" - - "var r48 = r.H >>> 16;" - "var r32 = r.H & 0xFFFF;" - "var r16 = r.L >>> 16;" - "var r00 = r.L & 0xFFFF;" - - "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" - "x00 += l00 + r00;" - "x16 += x00 >>> 16;" - "x00 &= 0xFFFF;" - "x16 += l16 + r16;" - "x32 += x16 >>> 16;" - "x16 &= 0xFFFF;" - "x32 += l32 + r32;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x48 += l48 + r48;" - "x48 &= 0xFFFF;" - - "return LuxRT$makeI64((x48 << 16) | x32, (x16 << 16) | x00);" - "})") - "subI64" (str "(function LuxRT$subI64(l,r) {" - "return LuxRT$addI64(l,LuxRT$negateI64(r));" - "})") - "mulI64" (str "(function LuxRT$mulI64(l,r) {" - "if (l.H < 0) {" - (str "if (r.H < 0) {" - ;; Both are negative - "return LuxRT$mulI64(LuxRT$negateI64(l),LuxRT$negateI64(r));" - "}" - "else {" - ;; Left is negative - "return LuxRT$negateI64(LuxRT$mulI64(LuxRT$negateI64(l),r));" - "}") - "}" - "else if (r.H < 0) {" - ;; Right is negative - "return LuxRT$negateI64(LuxRT$mulI64(l,LuxRT$negateI64(r)));" - "}" - ;; Both are positive - "else {" - "var l48 = l.H >>> 16;" - "var l32 = l.H & 0xFFFF;" - "var l16 = l.L >>> 16;" - "var l00 = l.L & 0xFFFF;" - - "var r48 = r.H >>> 16;" - "var r32 = r.H & 0xFFFF;" - "var r16 = r.L >>> 16;" - "var r00 = r.L & 0xFFFF;" - - "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" - "x00 += l00 * r00;" - "x16 += x00 >>> 16;" - "x00 &= 0xFFFF;" - "x16 += l16 * r00;" - "x32 += x16 >>> 16;" - "x16 &= 0xFFFF;" - "x16 += l00 * r16;" - "x32 += x16 >>> 16;" - "x16 &= 0xFFFF;" - "x32 += l32 * r00;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x32 += l16 * r16;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x32 += l00 * r32;" - "x48 += x32 >>> 16;" - "x32 &= 0xFFFF;" - "x48 += (l48 * r00) + (l32 * r16) + (l16 * r32) + (l00 * r48);" - "x48 &= 0xFFFF;" - - "return LuxRT$makeI64((x48 << 16) | x32, (x16 << 16) | x00);" - "}" - "})") - "divI64" (str "(function LuxRT$divI64(l,r) {" - (str "if((r.H === 0) && (r.L === 0)) {" - ;; Special case: R = 0 - "throw new Error('Cannot divide by zero!');" - "}" - "else if((l.H === 0) && (l.L === 0)) {" - ;; Special case: L = 0 - "return l;" - "}") - (str "if(LuxRT$eqI64(l,LuxRT$MIN_VALUE_I64)) {" - ;; Special case: L = MIN - (str "if(LuxRT$eqI64(r,LuxRT$ONE) || LuxRT$eqI64(r,LuxRT$negateI64(LuxRT$ONE))) {" - ;; Special case: L = MIN, R = 1|-1 - "return LuxRT$MIN_VALUE_I64;" - "}" - ;; Special case: L = R = MIN - "else if(LuxRT$eqI64(r,LuxRT$MIN_VALUE_I64)) {" - "return LuxRT$ONE;" - "}" - ;; Special case: L = MIN - "else {" - "var halfL = LuxRT$shrI64(l,1);" - "var approx = LuxRT$shlI64(LuxRT$divI64(halfL,r),LuxRT$ONE);" - (str "if((approx.H === 0) && (approx.L === 0)) {" - (str "if(r.H < 0) {" - "return LuxRT$ONE;" - "}" - "else {" - "return LuxRT$negateI64(LuxRT$ONE);" - "}") - "}" - "else {" - "var rem = LuxRT$subI64(l,LuxRT$mulI64(r,approx));" - "return LuxRT$addI64(approx,LuxRT$divI64(rem,r));" - "}") - "}") - "}" - "else if(LuxRT$eqI64(r,LuxRT$MIN_VALUE_I64)) {" - ;; Special case: R = MIN - "return LuxRT$makeI64(0,0);" - "}") - ;; Special case: negatives - (str "if(l.H < 0) {" - (str "if(r.H < 0) {" - ;; Both are negative - "return LuxRT$divI64(LuxRT$negateI64(l),LuxRT$negateI64(r));" - "}" - "else {" - ;; Only L is negative - "return LuxRT$negateI64(LuxRT$divI64(LuxRT$negateI64(l),r));" - "}") - "}" - "else if(r.H < 0) {" - ;; R is negative - "return LuxRT$negateI64(LuxRT$divI64(l,LuxRT$negateI64(r)));" - "}") - ;; Common case - (str "var res = LuxRT$ZERO;" - "var rem = l;" - (str "while(LuxRT$ltI64(r,rem) || LuxRT$eqI64(r,rem)) {" - "var approx = Math.max(1, Math.floor(LuxRT$toNumberI64(rem) / LuxRT$toNumberI64(r)));" - "var log2 = Math.ceil(Math.log(approx) / Math.LN2);" - "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);" - "var approxRes = LuxRT$fromNumberI64(approx);" - "var approxRem = LuxRT$mulI64(approxRes,r);" - (str "while((approxRem.H < 0) || LuxRT$ltI64(rem,approxRem)) {" - "approx -= delta;" - "approxRes = LuxRT$fromNumberI64(approx);" - "approxRem = LuxRT$mulI64(approxRes,r);" - "}") - (str "if((approxRes.H === 0) && (approxRes.L === 0)) {" - "approxRes = LuxRT$ONE;" - "}") - "res = LuxRT$addI64(res,approxRes);" - "rem = LuxRT$subI64(rem,approxRem);" - "}") - "return res;") - "})") - "remI64" (str "(function LuxRT$remI64(l,r) {" - "return LuxRT$subI64(l,LuxRT$mulI64(LuxRT$divI64(l,r),r));" - "})") - "ltI64" (str "(function LuxRT$ltI64(l,r) {" - "var ln = l.H < 0;" - "var rn = r.H < 0;" - "if(ln && !rn) { return true; }" - "if(!ln && rn) { return false; }" - "return (LuxRT$subI64(l,r).H < 0);" - "})") - }) - -(def ^:private n64-methods - {"divWord" (str "(function LuxRT$divWord(result, n, d) {" - "var dLong = LuxRT$makeI64(0,d);" - (str "if (LuxRT$eqI64(dLong,LuxRT$ONE)) {" - (str "result[0] = n.L;" - "result[1] = 0;" - "return") - "}" - "else {" - ;; Approximate the quotient and remainder - (str "var q = LuxRT$divI64(LuxRT$ushrI64(n,1),LuxRT$ushrI64(dLong,1));" - "var r = LuxRT$subI64(n,LuxRT$mulI64(q,dLong));" - ;; Correct the approximation - (str "while(LuxRT$ltI64(r,LuxRT$ZERO)) {" - "r = LuxRT$addI64(r,dLong);" - "q = LuxRT$subI64(q,LuxRT$ONE);" - "}") - (str "while(LuxRT$ltI64(dLong,r) || LuxRT$eqI64(dLong,r)) {" - "r = LuxRT$subI64(r,dLong);" - "q = LuxRT$addI64(q,LuxRT$ONE);" - "}") - "result[0] = q.L;" - "result[1] = r.L;" - ) - "}") - "})") - "primitiveShiftLeftBigInt" (str "(function LuxRT$primitiveShiftLeftBigInt(input,shift) {" - "var output = input.slice();" - "var shift2 = 32 - shift;" - (str "for(var i = 0, c = output[i], m = (i + (input.length - 1)); i < m; i++) {" - "var b = c;" - "c = output[i+1];" - "output[i] = (b << shift) | (c >>> shift2);" - "}") - "output[(input.length - 1)] <<= shift;" - "return output;" - "})") - "primitiveShiftRightBigInt" (str "(function LuxRT$primitiveShiftRightBigInt(input,shift) {" - "var output = input.slice();" - "var shift2 = 32 - shift;" - (str "for(var i = (input.length - 1), c = output[i]; i > 0; i--) {" - "var b = c;" - "c = output[i-1];" - "output[i] = (c << shift2) | (b >>> shift);" - "}") - "output[0] >>>= shift;" - "return output;" - "})") - "shiftLeftBigInt" (str "(function LuxRT$shiftLeftBigInt(input,shift) {" - "var shiftInts = shift >>> 5;" - "var shiftBits = shift & 0x1F;" - "var bitsInHighWord = LuxRT$countI64(LuxRT$makeI64(input[0],0));" - (str "if(shift <= (32 - bitsInHighWord)) {" - "var shifted = LuxRT$shlI64(LuxRT$makeI64(input[0],input[1]),shiftBits);" - "return [shifted.H,shifted.L];" - "}") - "var inputLen = input[0] === 0 ? 1 : 2;" - "var newLen = inputLen + shiftInts + 1;" - (str "if(shiftBits <= (32 - bitsInHighWord)) {" - "newLen--;" - "}") - (str "if(input.length < newLen) {" - ;; The array must grow - "input = [0|0,input[0],input[1]];" - "}") - (str "if(nBits == 0) {" - "return input;" - "}") - (str "if(shiftBits <= (32 - bitsInHighWord)) {" - "return LuxRT$primitiveShiftLeftBigInt(input,shiftBits);" - "}" - "else {" - "return LuxRT$primitiveShiftRightBigInt(input,(32 - shiftBits));" - "}") - "})") - "shiftRightBigInt" (str "(function LuxRT$shiftRightBigInt(input,shift) {" - "var shiftInts = shift >>> 5;" - "var shiftBits = shift & 0x1F;" - "if(shiftBits === 0) { return input; }" - "var bitsInHighWord = LuxRT$countI64(LuxRT$makeI64(input[0],0));" - (str "if(shiftBits >= bitsInHighWord) {" - "return LuxRT$primitiveShiftLeftBigInt(input,(32-shiftBits));" - "}" - "else {" - "return LuxRT$primitiveShiftRightBigInt(input,shiftBits);" - "}") - "})") - "mulsubBigInt" (str "(function LuxRT$mulsubBigInt(q, a, x, len, offset) {" - "var xLong = LuxRT$makeI64(0,x);" - "var carry = LuxRT$ZERO;" - "offset += len;" - (str "for (var j = len-1; j >= 0; j--) {" - "var product = LuxRT$addI64(LuxRT$mulI64(LuxRT$makeI64(0,a[j]),xLong),carry);" - "var difference = LuxRT$subI64(LuxRT$makeI64(0,q[offset]),product);" - "carry = LuxRT$addI64(LuxRT$ushrI64(product,32),((difference.L > ~product.L) ? LuxRT$ONE : LuxRT$ZERO));" - "}") - "return carry.L;" - "})") - "divadd" (str "(function LuxRT$divadd(a, result, offset) {" - "var carry = LuxRT$ZERO;" - (str "for (var j = a.length - 1; j >= 0; j--) {" - "var sum = LuxRT$addI64(LuxRT$addI64(LuxRT$makeI64(0,a[j]),LuxRT$makeI64(0,result[j+offset])),carry);" - "result[j+offset] = sum.L;" - "carry = LuxRT$ushrI64(sum,32);" - "}") - "return carry.L;" - "})") - "normalizeBigInt" (str "(function LuxRT$normalizeBigInt(input) {" - (str "if(input[0] !== 0) {" - "return LuxRT$makeI64(input[0],input[1]);" - "}" - "else {" - (str "var numZeros = 0;" - (str "do {" - "numZeros++;" - "} while(numZeros < input.length && input[numZeros] == 0);") - "var tempInput = input.slice(input.length-Math.max(2,input.length-numZeros));" - "return LuxRT$makeI64(tempInput[0],tempInput[1]);") - "}") - "})") - "divideOneWord" (str "(function LuxRT$divideOneWord(subject,param) {" - (str "var divLong = LuxRT$makeI64(0,param);" - ;; Special case of one word dividend - (str "if(subject.H === 0) {" - (str "var remValue = LuxRT$makeI64(0,subject.L);" - "var quotient = LuxRT$divI64(remValue,divLong);" - "var remainder = LuxRT$subI64(remValue,LuxRT$mulI64(quotient.L,divLong));" - "return [quotient,remainder];") - "}") - "var quotient = [0|0,0|0];" - ;; Normalize the divisor - "var shift = 32 - LuxRT$countI64(LuxRT$makeI64(0,param));" - "var rem = subject.H;" - "var remLong = LuxRT$makeI64(0,rem);" - (str "if(LuxRT$ltI64(remLong,divLong)) {" - "quotient[0] = 0|0;" - "}" - "else {" - "quotient[0] = LuxRT$divI64(remLong,divLong).L;" - "rem = LuxRT$subI64(remLong,LuxRT$mulI64(quotient[0],divLong)).L;" - "remLong = LuxRT$makeI64(0,rem);" - "}") - "var remBI = [subject.H,subject.L];" - "var xlen = 2;" - "var qWord = [0|0,0|0];" - (str "while(--xlen > 0) {" - "var dividendEstimate = LuxRT$orI64(LuxRT$shlI64(remLong,32),LuxRT$makeI64(0,remBI[2 - xlen]));" - (str "if(dividendEstimate >= 0) {" - "var highWord = LuxRT$divI64(dividendEstimate,divLong);" - "qWord[0] = highWord.L;" - "qWord[1] = LuxRT$subI64(dividendEstimate,LuxRT$mulI64(highWord,divLong)).L;" - "}" - "else {" - "LuxRT$divWord(qWord, dividendEstimate, param);" - "}") - "quotient[2 - xlen] = qWord[0];" - "rem = qWord[1];" - "remLong = LuxRT$makeI64(0,rem);" - "}") - ;; Unnormalize - (str "if(shift > 0) {" - "rem %= divisor;" - "remBI[0] = rem;" - "}" - "else {" - "remBI[0] = rem;" - "}") - "var quotI64 = LuxRT$normalizeBigInt(quotient);" - "var remI64 = LuxRT$makeI64(remBI[0],remBI[1]);" - "return [quotI64,remI64];") - "})") - "divmodBigInt" (str "(function LuxRT$divmodBigInt(subject,param) {" - (str "if(LuxRT$eqI64(param,LuxRT$ZERO)) {" - "throw new Error('Cannot divide by zero!');" - "}") - (str "if(LuxRT$eqI64(subject,LuxRT$ZERO)) {" - "return [LuxRT$ZERO, LuxRT$ZERO];" - "}") - (str "if(LuxRT$ltN64(subject,param)) {" - "return [LuxRT$ZERO, subject];" - "}") - (str "if(LuxRT$eqI64(subject,param)) {" - "return [LuxRT$ONE, LuxRT$ZERO];" - "}") - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (str "if (param.H === 0) {" - "return LuxRT$divideOneWord(subject,param.L);;" - "}") - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - "var divisor = param;" - "var remainder = subject.H === 0 ? [0|0,subject.L] : [0|0,subject.H,subject.L];" - "var paramLength = param.H === 0 ? 1 : 2;" - "var subjLength = subject.H === 0 ? 1 : 2;" - "var limit = subjLength - paramLength + 1;" - "var quotient = (limit === 1) ? [0|0] : [0|0,0|0];" - ;; Normalize the divisor - "var shift = 32 - LuxRT$countI64(LuxRT$makeI64(divisor.H,0));" - (str "if(shift > 0) {" - "divisor = LuxRT$shlI64(divisor,shift);" - "remainder = LuxRT$shiftLeftBigInt(remainder,shift);" - "}") - (str "if((remainder.length-1) === subjLength) {" - "remainder[0] = 0;" - "}") - "var dh = divisor.H;" - "var dhLong = LuxRT$makeI64(0,dh);" - "var dl = divisor.L;" - "var qWord = [0|0,0|0];" - ;; D2 Initialize j - (str "for(var j = 0; j < limit; j++) {" - ;; D3 Calculate qhat - ;; estimate qhat - "var qhat = 0;" - "var qrem = 0;" - "var skipCorrection = false;" - "var nh = remainder[j];" - "var nh2 = nh + 0x80000000;" - "var nm = remainder[j+1];" - (str "if(nh == dh) {" - (str "qhat = ~0;" - "qrem = nh + nm;" - "skipCorrection = (qrem + 0x80000000) < nh2;") - "}" - "else {" - (str "var nChunk = LuxRT$orI64(LuxRT$shlI64(LuxRT$fromNumberI64(nh),32),LuxRT$fromNumberI64(nm));") - (str "if(LuxRT$ltI64(LuxRT$ZERO,nChunk) || LuxRT$eqI64(LuxRT$ZERO,nChunk)) {" - (str "qhat = LuxRT$divI64(nChunk,dhLong).L;" - "qrem = LuxRT$subI64(nChunk,LuxRT$mulI64(qhat, dhLong)).L;") - "}" - "else {" - (str "LuxRT$divWord(qWord, nChunk, dh);" - "qhat = qWord[0];" - "qrem = qWord[1];" - ) - "}") - "if(qhat == 0) { continue; }" - (str "if(!skipCorrection) {" - ;; Correct qhat - (str "var qremLong = LuxRT$makeI64(0,qrem);" - "var dlLong = LuxRT$makeI64(0,dl);" - "var nl = LuxRT$makeI64(0,remainder[j+2]);" - "var rs = LuxRT$orI64(LuxRT$shlI64(qremLong,32),nl);" - "var estProduct = LuxRT$mulI64(dlLong,LuxRT$makeI64(0,qhat));" - (str "if(LuxRT$ltN64(rs,estProduct)) {" - (str "qhat--;" - "qrem = LuxRT$addI64(qremLong,dhLong).L;" - "qremLong = LuxRT$makeI64(0,qrem);" - (str "if(LuxRT$ltI64(dhLong,qremLong) || LuxRT$eqI64(dhLong,qremLong)) {" - (str "estProduct = LuxRT$mulI64(dlLong,LuxRT$makeI64(0,qhat));" - "rs = LuxRT$orI64(LuxRT$shlI64(qremLong,32),nl);" - "if(LuxRT$ltN64(rs,estProduct)) { qhat--; }") - "}")) - "}") - ) - "}") - ;; D4 Multiply and subtract - "remainder[j] = 0;" - "var borrow = LuxRT$mulsubBigInt(remainder, divisor, qhat, paramLength, j);" - ;; D5 Test remainder - (str "if((borrow + 0x80000000) > nh2) {" - ;; D6 Add back - "LuxRT$divadd(divisor, remainder, j+1);" - "qhat--;" - "}") - ;; Store the quotient digit - "quotient[j] = qhat;" - "}") - "}") ;; D7 loop on j - ;; D8 Unnormalize - "if(shift > 0) { remainder = LuxRT$shiftRightBigInt(remainder,shift); }" - "return [LuxRT$normalizeBigInt(quotient), LuxRT$normalizeBigInt(remainder)];" - "})") - "divN64" (str "(function LuxRT$divN64(l,r) {" - (str "if(LuxRT$ltI64(r,LuxRT$ZERO)) {" - (str "if(LuxRT$ltN64(l,r)) {" - "return LuxRT$ZERO;" - "}" - "else {" - "return LuxRT$ONE;" - "}") - "}" - "else if(LuxRT$ltI64(LuxRT$ZERO,l)) {" - "return LuxRT$divI64(l,r);" - "}" - "else {" - (str "if(LuxRT$eqI64(LuxRT$ZERO,r)) {" - "throw new Error('Cannot divide by zero!');" - "}" - "else {" - (str "if(LuxRT$ltI64(l,r)) {" - "return LuxRT$ZERO;" - "}" - "else {" - "return LuxRT$divmodBigInt(l,r)[0];" - "}") - "}") - "}") - "})") - "remN64" (str "(function LuxRT$remN64(l,r) {" - (str "if(LuxRT$ltI64(l,LuxRT$ZERO) || LuxRT$ltI64(r,LuxRT$ZERO)) {" - (str "if(LuxRT$ltN64(l,r)) {" - "return l;" - "}" - "else {" - "return LuxRT$divmodBigInt(l,r)[1];" - "}") - "}" - "else {" - "return LuxRT$remI64(l,r);" - "}") - "})") - "ltN64" (str "(function LuxRT$ltN64(l,r) {" - "var li = LuxRT$addI64(l,LuxRT$MIN_VALUE_I64);" - "var ri = LuxRT$addI64(r,LuxRT$MIN_VALUE_I64);" - "return LuxRT$ltI64(li,ri);" - "})") - }) - -(def ^:private d64-methods - {"mulD64" (str "(function LuxRT$mulD64(l,r) {" - "var lL = LuxRT$fromNumberI64(l.L);" - "var rL = LuxRT$fromNumberI64(r.L);" - "var lH = LuxRT$fromNumberI64(l.H);" - "var rH = LuxRT$fromNumberI64(r.H);" - - "var bottom = LuxRT$ushrI64(LuxRT$mulI64(lL,rL),32);" - "var middle = LuxRT$addI64(LuxRT$mulI64(lH,rL),LuxRT$mulI64(lL,rH));" - "var top = LuxRT$mulI64(lH,rH);" - - "var bottomAndMiddle = LuxRT$ushrI64(LuxRT$addI64(middle,bottom),32);" - - "return LuxRT$addI64(top,bottomAndMiddle);" - "})") - "countLeadingZeroes" (str "(function LuxRT$countLeadingZeroes(input) {" - "var zeroes = 64;" - (str "while(!LuxRT$eqI64(input,LuxRT$ZERO)) {" - "zeroes--;" - "input = LuxRT$ushrI64(input,1);" - "}") - "return zeroes;" - "})") - "divD64" (str "(function LuxRT$divD64(l,r) {" - (str "if(LuxRT$eqI64(l,r)) {" - "return LuxRT$negateI64(LuxRT$ONE);" ;; ~= 1.0 DEG - "}" - "else {" - "var minShift = Math.min(LuxRT$countLeadingZeroes(l), LuxRT$countLeadingZeroes(r));" - "l = LuxRT$shlI64(l,minShift);" - "r = LuxRT$shlI64(r,minShift);" - "return LuxRT$shlI64(LuxRT$divI64(l,LuxRT$fromNumberI64(r.H)),32);" - "}") - "})") - "degToFrac" (str "(function LuxRT$degToFrac(input) {" - "var two32 = Math.pow(2,32);" - "var high = input.H / two32;" - "var low = (input.L / two32) / two32;" - "return high+low;" - "})") - "fracToDeg" (str "(function LuxRT$fracToDeg(input) {" - "var two32 = Math.pow(2,32);" - "var shifted = (input % 1.0) * two32;" - "var low = ((shifted % 1.0) * two32) | 0;" - "var high = shifted | 0;" - "return LuxRT$makeI64(high,low);" - "})") - }) - -(def ^:private io-methods - {"log" (str "(function LuxRT$log(message) {" - "console.log(message);" - (str "return " &&/unit ";") - "})") - "error" (str "(function LuxRT$error(message) {" - "throw new Error(message);" - (str "return null;") - "})") - }) - -(def ^:private text-methods - {"index" (str "(function LuxRT$index(text,part,start) {" - "var idx = text.indexOf(part,LuxRT$toNumberI64(start));" - (str (str "if(idx === -1) {" - "return " const-none ";" - "}") - (str "else {" - (str "return " (make-some "LuxRT$fromNumberI64(idx)") ";") - "}")) - "})") - "lastIndex" (str "(function LuxRT$lastIndex(text,part,start) {" - "var idx = text.lastIndexOf(part,LuxRT$toNumberI64(start));" - (str (str "if(idx === -1) {" - "return " const-none ";" - "}") - (str "else {" - (str "return " (make-some "LuxRT$fromNumberI64(idx)") ";") - "}")) - "})") - "clip" (str "(function LuxRT$clip(text,from,to) {" - (str "if(from.L > text.length || to.L > text.length) {" - (str "return " const-none ";") - "}" - "else {" - (str "return " (make-some "text.substring(from.L,to.L)") ";") - "}") - "})") - "replaceAll" (str "(function LuxRT$replaceAll(text,toFind,replaceWith) {" - "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" - "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" - "})") - "textChar" (str "(function LuxRT$textChar(text,idx) {" - "var result = text.charAt(idx.L);" - (str "if(result === '') {" - (str "return " const-none ";") - "}" - "else {" - (str "return " (make-some "{'C':result}") ";") - "}") - "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" - "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" - "})") - "textHash" (str "(function LuxRT$textHash(input) {" - "var hash = 0;" - (str "for(var i = 0; i < input.length; i++) {" - "hash = (((hash << 5) - hash) + input.charCodeAt(i)) & 0xFFFFFFFF;" - "}") - "return LuxRT$fromNumberI64(hash);" - "})") - }) - -(def ^:private array-methods - {"arrayGet" (str "(function LuxRT$arrayGet(arr,idx) {" - "var temp = arr[LuxRT$toNumberI64(idx)];" - (str "if(temp !== undefined) {" - (str "return " (make-some "temp") ";") - "}" - "else {" - (str "return " const-none ";") - "}") - "})") - "arrayPut" (str "(function LuxRT$arrayPut(arr,idx,val) {" - "arr[LuxRT$toNumberI64(idx)] = val;" - "return arr;" - "})") - "arrayRemove" (str "(function LuxRT$arrayRemove(arr,idx) {" - "delete arr[LuxRT$toNumberI64(idx)];" - "return arr;" - "})") - }) - -(def ^:private bit-methods - (let [make-basic-op (fn [op name] - (str "(function " name "(input,mask) {" - "return LuxRT$makeI64(input.H " op " mask.H, input.L " op " mask.L);" - "})"))] - {"andI64" (make-basic-op "&" "LuxRT$andI64") - "orI64" (make-basic-op "|" "LuxRT$orI64") - "xorI64" (make-basic-op "^" "LuxRT$xorI64") - "countI64" (str "(function LuxRT$countI64(input) {" - "var hs = (input.H).toString(2);" - "var ls = (input.L).toString(2);" - "var num1s = hs.concat(ls).replace(/0/g,'').length;" - "return LuxRT$fromNumberI64(num1s);" - "})") - "shlI64" (str "(function LuxRT$shlI64(input,shift) {" - "shift &= 63;" - (str "if(shift === 0) {" - "return input;" - "}" - "else {" - (str "if (shift < 32) {" - "var high = (input.H << shift) | (input.L >>> (32 - shift));" - "var low = input.L << shift;" - "return LuxRT$makeI64(high, low);" - "}" - "else {" - "var high = (input.L << (shift - 32));" - "return LuxRT$makeI64(high, 0);" - "}") - "}") - "})") - "shrI64" (str "(function LuxRT$shrI64(input,shift) {" - "shift &= 63;" - (str "if(shift === 0) {" - "return input;" - "}" - "else {" - (str "if (shift < 32) {" - "var high = input.H >> shift;" - "var low = (input.L >>> shift) | (input.H << (32 - shift));" - "return LuxRT$makeI64(high, low);" - "}" - "else {" - "var low = (input.H >> (shift - 32));" - "var high = input.H >= 0 ? 0 : -1;" - "return LuxRT$makeI64(high, low);" - "}") - "}") - "})") - "ushrI64" (str "(function LuxRT$ushrI64(input,shift) {" - "shift &= 63;" - (str "if(shift === 0) {" - "return input;" - "}" - "else {" - (str "if (shift < 32) {" - "var high = input.H >>> shift;" - "var low = (input.L >>> shift) | (input.H << (32 - shift));" - "return LuxRT$makeI64(high, low);" - "}" - "else if(shift === 32) {" - "return LuxRT$makeI64(0, input.H);" - "}" - "else {" - "var low = (input.H >>> (shift - 32));" - "return LuxRT$makeI64(0, low);" - "}") - "}") - "})") - })) - -(def ^:private lux-methods - {"clean_separators" (str "(function LuxRT$clean_separators(input) {" - "return input.replace(/_/g,'');" - "})") - "runTry" (str "(function LuxRT$runTry(op) {" - (str "try {" - (str "return [1,'',op(null)];") - "}" - "catch(ex) {" - (str "return [0,null,ex.toString()];") - "}") - "})") - "programArgs" (str "(function LuxRT$programArgs() {" - (str "if(typeof process !== 'undefined' && process.argv) {" - (str (str "var result = " const-none ";") - "for(var idx = process.argv.length-1; idx >= 0; idx--) {" - (str "result = " (make-some "[process.argv[idx],result]") ";") - "}") - (str "return result;") - "}" - "else {" - (str "return " const-none ";") - "}") - "})") - }) - -(def ^:private js-methods - {"jsSetField" (str "(function LuxRT$jsSetField(object, field, input) {" - "object[field] = input;" - "return object;" - "})") - "jsDeleteField" (str "(function LuxRT$jsDeleteField(object, field) {" - "delete object[field];" - "return object;" - "})") - "jsObjectCall" (str "(function LuxRT$jsObjectCall(object, method, args) {" - "return object[method].apply(object, args);" - "})") - }) - -(def LuxRT "LuxRT") - -(def compile-LuxRT - (&&/save-js! LuxRT - (->> (merge lux-methods - adt-methods - i64-methods - n64-methods - d64-methods - text-methods - array-methods - bit-methods - io-methods - js-methods) - (reduce (fn [prev [key val]] (str prev "var LuxRT$" key " = " val ";\n")) - "")))) |