aboutsummaryrefslogtreecommitdiff
path: root/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/compiler.clj11
-rw-r--r--luxc/src/lux/compiler/js.clj187
-rw-r--r--luxc/src/lux/compiler/js/base.clj243
-rw-r--r--luxc/src/lux/compiler/js/cache.clj40
-rw-r--r--luxc/src/lux/compiler/js/lux.clj387
-rw-r--r--luxc/src/lux/compiler/js/proc/common.clj567
-rw-r--r--luxc/src/lux/compiler/js/proc/host.clj86
-rw-r--r--luxc/src/lux/compiler/js/rt.clj863
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 &&parallel]
- [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 &&parallel]
- [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!! (&&parallel/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"))
- ""))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 06:59:55 +0000