aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lux-lein/src/leiningen/lux/builder.clj19
-rw-r--r--lux-lein/src/leiningen/lux/packager.clj18
-rw-r--r--lux-lein/src/leiningen/lux/test.clj41
-rw-r--r--lux-lein/src/leiningen/lux/utils.clj16
-rw-r--r--lux-mode/lux-mode.el2
-rw-r--r--luxc/src/lux.clj9
-rw-r--r--luxc/src/lux/analyser.clj25
-rw-r--r--luxc/src/lux/analyser/lux.clj101
-rw-r--r--luxc/src/lux/analyser/module.clj56
-rw-r--r--luxc/src/lux/analyser/proc/common.clj651
-rw-r--r--luxc/src/lux/analyser/proc/js.clj93
-rw-r--r--luxc/src/lux/analyser/proc/jvm.clj (renamed from luxc/src/lux/analyser/host.clj)546
-rw-r--r--luxc/src/lux/base.clj404
-rw-r--r--luxc/src/lux/compiler.clj277
-rw-r--r--luxc/src/lux/compiler/cache.clj172
-rw-r--r--luxc/src/lux/compiler/core.clj82
-rw-r--r--luxc/src/lux/compiler/host.clj2762
-rw-r--r--luxc/src/lux/compiler/io.clj42
-rw-r--r--luxc/src/lux/compiler/js.clj190
-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.clj391
-rw-r--r--luxc/src/lux/compiler/js/proc/common.clj612
-rw-r--r--luxc/src/lux/compiler/js/proc/host.clj86
-rw-r--r--luxc/src/lux/compiler/js/rt.clj1058
-rw-r--r--luxc/src/lux/compiler/jvm.clj263
-rw-r--r--luxc/src/lux/compiler/jvm/base.clj (renamed from luxc/src/lux/compiler/base.clj)41
-rw-r--r--luxc/src/lux/compiler/jvm/cache.clj64
-rw-r--r--luxc/src/lux/compiler/jvm/case.clj (renamed from luxc/src/lux/compiler/case.clj)4
-rw-r--r--luxc/src/lux/compiler/jvm/lambda.clj (renamed from luxc/src/lux/compiler/lambda.clj)4
-rw-r--r--luxc/src/lux/compiler/jvm/lux.clj (renamed from luxc/src/lux/compiler/lux.clj)16
-rw-r--r--luxc/src/lux/compiler/jvm/proc/common.clj1057
-rw-r--r--luxc/src/lux/compiler/jvm/proc/host.clj1145
-rw-r--r--luxc/src/lux/compiler/jvm/rt.clj1476
-rw-r--r--luxc/src/lux/compiler/module.clj23
-rw-r--r--luxc/src/lux/lexer.clj4
-rw-r--r--luxc/src/lux/repl.clj6
-rw-r--r--luxc/src/lux/type.clj152
-rw-r--r--luxc/src/lux/type/host.clj72
-rw-r--r--stdlib/source/lux.lux567
-rw-r--r--stdlib/source/lux/concurrency/atom.lux20
-rw-r--r--stdlib/source/lux/concurrency/promise.lux47
-rw-r--r--stdlib/source/lux/concurrency/stm.lux1
-rw-r--r--stdlib/source/lux/control/comonad.lux11
-rw-r--r--stdlib/source/lux/control/monad.lux13
-rw-r--r--stdlib/source/lux/data/char.lux50
-rw-r--r--stdlib/source/lux/data/coll/list.lux2
-rw-r--r--stdlib/source/lux/data/number.lux148
-rw-r--r--stdlib/source/lux/data/text.lux112
-rw-r--r--stdlib/source/lux/host.js.lux83
-rw-r--r--stdlib/source/lux/host.jvm.lux (renamed from stdlib/source/lux/host.lux)0
-rw-r--r--stdlib/source/lux/io.lux2
-rw-r--r--stdlib/source/lux/macro/ast.lux2
-rw-r--r--stdlib/source/lux/math.lux61
-rw-r--r--stdlib/source/lux/math/complex.lux8
-rw-r--r--stdlib/source/lux/test.lux20
-rw-r--r--stdlib/test/test/lux.lux16
-rw-r--r--stdlib/test/test/lux/data/char.lux3
-rw-r--r--stdlib/test/test/lux/data/text.lux16
-rw-r--r--stdlib/test/test/lux/host.js.lux32
-rw-r--r--stdlib/test/test/lux/host.jvm.lux (renamed from stdlib/test/test/lux/host.lux)0
-rw-r--r--stdlib/test/test/lux/math.lux3
-rw-r--r--stdlib/test/test/lux/math/complex.lux16
63 files changed, 8877 insertions, 4619 deletions
diff --git a/lux-lein/src/leiningen/lux/builder.clj b/lux-lein/src/leiningen/lux/builder.clj
index ca9088d4c..65f45b90c 100644
--- a/lux-lein/src/leiningen/lux/builder.clj
+++ b/lux-lein/src/leiningen/lux/builder.clj
@@ -4,10 +4,17 @@
[packager :as &packager])))
(defn build [project]
- (if-let [program-module (get-in project [:lux :program])]
- (when (&utils/run-process (&utils/compile-path project program-module (get project :source-paths (list)))
- nil
- "[BUILD BEGIN]"
- "[BUILD END]")
- (&packager/package project program-module (get project :resource-paths (list))))
+ (if-let [program-modules (get-in project [:lux :program])]
+ (do (when-let [jvm-module (get-in program-modules [:jvm])]
+ (when (&utils/run-process (&utils/compile-path project "jvm" jvm-module (get project :source-paths (list)))
+ nil
+ "[BUILD BEGIN]"
+ "[BUILD END]")
+ (&packager/package project "jvm" jvm-module (get project :resource-paths (list)))))
+ (when-let [js-module (get-in program-modules [:js])]
+ (when (&utils/run-process (&utils/compile-path project "js" js-module (get project :source-paths (list)))
+ nil
+ "[BUILD BEGIN]"
+ "[BUILD END]")
+ (&packager/package project "js" js-module (get project :resource-paths (list))))))
(println "Please provide a program main module in [:lux :program]")))
diff --git a/lux-lein/src/leiningen/lux/packager.clj b/lux-lein/src/leiningen/lux/packager.clj
index 3ac117d15..afb4a82db 100644
--- a/lux-lein/src/leiningen/lux/packager.clj
+++ b/lux-lein/src/leiningen/lux/packager.clj
@@ -123,11 +123,11 @@
(def default-manifest-file (str "." java.io.File/separator "AndroidManifest.xml"))
;; [Resources]
-(defn package
+(defn ^:private package-jvm
"(-> Text (List Text) Null)"
[project module resources-dirs]
(let [output-package-name (get project :jar-name &utils/output-package)
- output-dir (&utils/prepare-path (get-in project [:lux :target] &utils/default-output-dir))
+ output-dir (&utils/prepare-path (get-in project [:lux :target] &utils/default-jvm-output-dir))
output-package (str output-dir java.io.File/separator output-package-name)
!all-jar-files (atom {})
includes-android? (boolean (some #(-> % first (= 'com.google.android/android))
@@ -161,7 +161,7 @@
(.closeEntry)))
nil))
(when (get-in project [:lux :android])
- (let [output-dir-context (new File (get-in project [:lux :target] &utils/default-output-dir))
+ (let [output-dir-context (new File (get-in project [:lux :target] &utils/default-jvm-output-dir))
output-dex "classes.dex"
_ (do (.delete (new File output-dex))
(&utils/run-process (str "dx --dex --output=" output-dex " " output-package-name)
@@ -206,7 +206,13 @@
(&utils/run-process (str "zipalign 4 " output-apk-unaligned-path " " output-apk-path)
nil
"[ZIPALIGN BEGIN]"
- "[ZIPALIGN END]"))
- )
- ]
+ "[ZIPALIGN END]")))]
nil)))))
+
+(defn package
+ "(-> Text Text (List Text) Null)"
+ [project platform module resources-dirs]
+ (case platform
+ "jvm" (package-jvm project module resources-dirs)
+ "js" nil)
+ )
diff --git a/lux-lein/src/leiningen/lux/test.clj b/lux-lein/src/leiningen/lux/test.clj
index 77dc342e7..d3755c1b6 100644
--- a/lux-lein/src/leiningen/lux/test.clj
+++ b/lux-lein/src/leiningen/lux/test.clj
@@ -5,18 +5,31 @@
[packager :as &packager])))
(defn test [project]
- (if-let [tests-module (get-in project [:lux :tests])]
- (when (&utils/run-process (&utils/compile-path project tests-module (concat (:test-paths project) (:source-paths project)))
- nil
- "[BUILD BEGIN]"
- "[BUILD END]")
- (let [java-cmd (get project :java-cmd "java")
- jvm-opts (->> (get project :jvm-opts) (interpose " ") (reduce str ""))
- output-package (str (get-in project [:lux :target] &utils/default-output-dir) "/"
- (get project :jar-name &utils/output-package))]
- (do (&packager/package project tests-module (get project :resource-paths (list)))
- (&utils/run-process (str java-cmd " " jvm-opts " -jar " output-package)
- nil
- "[TEST BEGIN]"
- "[TEST END]"))))
+ (if-let [tests-modules (get-in project [:lux :tests])]
+ (do (when-let [jvm-module (get-in tests-modules [:jvm])]
+ (when (&utils/run-process (&utils/compile-path project "jvm" jvm-module (concat (:test-paths project) (:source-paths project)))
+ nil
+ "[BUILD BEGIN]"
+ "[BUILD END]")
+ (let [java-cmd (get project :java-cmd "java")
+ jvm-opts (->> (get project :jvm-opts) (interpose " ") (reduce str ""))
+ output-package (str (get-in project [:lux :target] &utils/default-jvm-output-dir) "/"
+ (get project :jar-name &utils/output-package))]
+ (do (&packager/package project "jvm" jvm-module (get project :resource-paths (list)))
+ (&utils/run-process (str java-cmd " " jvm-opts " -jar " output-package)
+ nil
+ "[TEST BEGIN]"
+ "[TEST END]")))))
+ (when-let [js-module (get-in tests-modules [:js])]
+ (when (&utils/run-process (&utils/compile-path project "js" js-module (concat (:test-paths project) (:source-paths project)))
+ nil
+ "[BUILD BEGIN]"
+ "[BUILD END]")
+ (let [output-package (str (get-in project [:lux :target] &utils/default-js-output-dir) "/"
+ "program.js")]
+ (do (&packager/package project "js" js-module (get project :resource-paths (list)))
+ (&utils/run-process (str "node " output-package)
+ nil
+ "[TEST BEGIN]"
+ "[TEST END]"))))))
(println "Please provide a test module in [:lux :tests]")))
diff --git a/lux-lein/src/leiningen/lux/utils.clj b/lux-lein/src/leiningen/lux/utils.clj
index c70ec2289..ae39c37b3 100644
--- a/lux-lein/src/leiningen/lux/utils.clj
+++ b/lux-lein/src/leiningen/lux/utils.clj
@@ -5,7 +5,8 @@
InputStreamReader
BufferedReader)))
-(def ^:const ^String default-output-dir (str "target" java.io.File/separator "jvm"))
+(def ^:const ^String default-jvm-output-dir (str "target" java.io.File/separator "jvm"))
+(def ^:const ^String default-js-output-dir (str "target" java.io.File/separator "js"))
(def ^:const ^String output-package "program.jar")
(def ^:private unit-separator (str (char 31)))
@@ -61,10 +62,17 @@
(str "lux " mode
" " (->> (get project :resource-paths (list)) (interpose unit-separator) (apply str))
" " (->> source-paths (interpose unit-separator) (apply str))
- " " (get-in project [:lux :target] default-output-dir)))
+ " " (get-in project [:lux :target] (cond (.contains mode "jvm")
+ default-jvm-output-dir
+
+ (.contains mode "js")
+ default-js-output-dir
+
+ :else
+ (assert false)))))
(do-template [<name> <mode>]
- (defn <name> [project module source-paths]
+ (defn <name> [project platform module source-paths]
(let [is-stdlib? (= stdlib-id [(get project :group) (get project :name)])
jar-paths (all-jars-in-classloader)
compiler-path (prepare-path (find-compiler-path jar-paths))
@@ -90,7 +98,7 @@
(str (java-command project) " -cp " class-path
" " (lux-command project <mode> source-paths))))
- compile-path (str "release " module)
+ compile-path (str "release " platform " " module)
repl-path "repl"
)
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el
index 5c50c3eea..6511c66cb 100644
--- a/lux-mode/lux-mode.el
+++ b/lux-mode/lux-mode.el
@@ -219,7 +219,7 @@ Called by `imenu--generic-function'."
"lambda" "case" ":" ":!" ":!!" "undefined" "ident-for"
"and" "or"
"exec" "let" "let%" "if" "cond" "do" "be" "open" "loop" "recur" "comment" "list" "list&" "io" "vector" "tree"
- "get@" "set@" "update@" "|>" "|>." "<|" "_$" "$_" "~" "~@" "~'" "::" ":::" "default"
+ "get@" "set@" "update@" "|>" "|>." "<|" "_$" "$_" "~" "~@" "~'" "::" ":::" "default" "assume"
"|" "&" "->" "All" "Ex" "Rec" "host" "$" "type"
"^" "^or" "^slots" "^stream&" "^=>" "^~" "^@" "^template" "^open" "^|>"
"bin" "oct" "hex"
diff --git a/luxc/src/lux.clj b/luxc/src/lux.clj
index 76778346d..2daf0000a 100644
--- a/luxc/src/lux.clj
+++ b/luxc/src/lux.clj
@@ -1,7 +1,6 @@
(ns lux
(:gen-class)
(:require [lux.base :as & :refer [|let |do return return* |case]]
- [lux.compiler.base :as &compiler-base]
[lux.compiler :as &compiler]
[lux.repl :as &repl]
[clojure.string :as string]
@@ -20,11 +19,11 @@
(defn -main [& args]
(|case (&/->list args)
- (&/$Cons "release" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))))
- (time (&compiler/compile-program &/$Release program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir))
+ (&/$Cons "release" (&/$Cons platform (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))))
+ (time (&compiler/compile-program platform &/$Release program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir))
- (&/$Cons "debug" (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil))))))
- (time (&compiler/compile-program &/$Debug program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir))
+ (&/$Cons "debug" (&/$Cons platform (&/$Cons program-module (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))))
+ (time (&compiler/compile-program platform &/$Debug program-module (separate-paths resources-dirs) (separate-paths source-dirs) target-dir))
(&/$Cons "repl" (&/$Cons resources-dirs (&/$Cons source-dirs (&/$Cons target-dir (&/$Nil)))))
(&repl/repl (separate-paths resources-dirs)
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj
index 51b5b4028..aaf441713 100644
--- a/luxc/src/lux/analyser.clj
+++ b/luxc/src/lux/analyser.clj
@@ -9,9 +9,11 @@
[host :as &host])
(lux.analyser [base :as &&]
[lux :as &&lux]
- [host :as &&host]
[module :as &&module]
- [parser :as &&a-parser])))
+ [parser :as &&a-parser])
+ (lux.analyser.proc [common :as &&common]
+ [jvm :as &&jvm]
+ [js :as &&js])))
;; [Utils]
(defn analyse-variant+ [analyse exo-type ident values]
@@ -56,10 +58,12 @@
(return (&&/|meta =output-type ?output-cursor ?output-term))))
))))
-(defn ^:private analyse-ast [optimize eval! compile-module compilers exo-type ?token]
+(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token]
(|let [analyse (partial analyse-ast optimize eval! compile-module compilers)
[cursor token] ?token
- [compile-def compile-program compile-class compile-interface] compilers]
+ compile-def (aget compilers 0)
+ compile-program (aget compilers 1)
+ macro-caller (aget compilers 2)]
(|case token
;; Standard special forms
(&/$BoolS ?value)
@@ -130,7 +134,14 @@
(&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil))) parameters]
(&/with-analysis-meta cursor exo-type
- (&&host/analyse-host analyse exo-type compilers ?category ?proc ?args)))
+ (case ?category
+ "jvm" (|do [_ &/jvm-host]
+ (&&jvm/analyse-host analyse exo-type compilers ?proc ?args))
+ "js" (|do [_ &/js-host]
+ (&&js/analyse-host analyse exo-type ?proc ?args))
+ ;; common
+ (&&common/analyse-proc analyse exo-type ?category ?proc ?args))
+ ))
"_lux_:"
(|let [(&/$Cons ?type
@@ -170,7 +181,7 @@
;; else
(&/with-cursor cursor
(|do [=fn (just-analyse analyse (&/T [command-meta command]))]
- (&&lux/analyse-apply analyse cursor exo-type =fn parameters))))
+ (&&lux/analyse-apply analyse cursor exo-type macro-caller =fn parameters))))
(&/$NatS idx)
(&/with-analysis-meta cursor exo-type
@@ -183,7 +194,7 @@
_
(&/with-cursor cursor
(|do [=fn (just-analyse analyse (&/T [command-meta command]))]
- (&&lux/analyse-apply analyse cursor exo-type =fn parameters))))
+ (&&lux/analyse-apply analyse cursor exo-type macro-caller =fn parameters))))
_
(&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (prn-str (&/show-ast (&/T [(&/T ["" -1 -1]) token])))))
diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj
index 5f3626900..304705331 100644
--- a/luxc/src/lux/analyser/lux.clj
+++ b/luxc/src/lux/analyser/lux.clj
@@ -375,43 +375,34 @@
(&&/$apply =fn =args)
)))))
-(defn analyse-apply [analyse cursor exo-type =fn ?args]
- (|do [loader &/loader
- :let [[[=fn-type =fn-cursor] =fn-form] =fn]]
- (|case =fn-form
- (&&/$var (&/$Global ?module ?name))
- (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)]
- (|case (&&meta/meta-get &&meta/macro?-tag ?meta)
- (&/$Some _)
- (|do [macro-expansion (fn [state]
- (|case (-> ?value (.apply ?args) (.apply state))
- (&/$Right state* output)
- (&/$Right (&/T [state* output]))
-
- (&/$Left error)
- ((&/fail-with-loc error) state)))
- module-name &/get-module-name
- ;; :let [[r-prefix r-name] real-name
- ;; _ (when (or (= "actor:" r-name)
- ;; ;; (= "|Codec@Json|" r-name)
- ;; ;; (= "|Codec@Json//encode|" r-name)
- ;; ;; (= "|Codec@Json//decode|" r-name)
- ;; ;; (= "derived:" r-name)
- ;; )
- ;; (->> (&/|map &/show-ast macro-expansion)
- ;; (&/|interpose "\n")
- ;; (&/fold str "")
- ;; (prn (&/ident->text real-name) module-name)))
- ;; ]
- ]
- (&/flat-map% (partial analyse exo-type) macro-expansion))
+(defn analyse-apply [analyse cursor exo-type macro-caller =fn ?args]
+ (|case =fn
+ [_ (&&/$var (&/$Global ?module ?name))]
+ (|do [[real-name [?type ?meta ?value]] (&&module/find-def ?module ?name)]
+ (|case (&&meta/meta-get &&meta/macro?-tag ?meta)
+ (&/$Some _)
+ (|do [macro-expansion (fn [state]
+ (|case (macro-caller ?value ?args state)
+ (&/$Right state* output)
+ (&/$Right (&/T [state* output]))
+
+ (&/$Left error)
+ ((&/fail-with-loc error) state)))
+ ;; module-name &/get-module-name
+ ;; :let [[r-prefix r-name] real-name
+ ;; _ (->> (&/|map &/show-ast macro-expansion)
+ ;; (&/|interpose "\n")
+ ;; (&/fold str "")
+ ;; (println 'macro-expansion (&/ident->text real-name) "@" module-name))]
+ ]
+ (&/flat-map% (partial analyse exo-type) macro-expansion))
- _
- (do-analyse-apply analyse exo-type =fn ?args)))
-
- _
- (do-analyse-apply analyse exo-type =fn ?args))
- ))
+ _
+ (do-analyse-apply analyse exo-type =fn ?args)))
+
+ _
+ (do-analyse-apply analyse exo-type =fn ?args))
+ )
(defn analyse-case [analyse exo-type ?value ?branches]
(|do [:let [num-branches (&/|length ?branches)]
@@ -560,7 +551,7 @@
module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
- (&/fail-with-loc (str "[Analyser Error] Can't redefine " (str module-name ";" ?name)))
+ (&/fail-with-loc (str "[Analyser Error] Can't re-define " (str module-name ";" ?name)))
(|do [=value (&/without-repl-closure
(&/with-scope ?name
(&&/analyse-1+ analyse ?value)))
@@ -568,28 +559,33 @@
==meta (eval! (optimize =meta))
_ (&&module/test-type module-name ?name ==meta (&&/expr-type* =value))
_ (&&module/test-macro module-name ?name ==meta (&&/expr-type* =value))
- _ (compile-def ?name (optimize =value) ==meta)]
+ _ (compile-def ?name (optimize =value) ==meta)
+ ;; TODO: Make the call to &type/reset-mappings unnecessary.
+ ;; It shouldn't be necessary to reset the mappings of the
+ ;; type-vars, because those mappings shouldn't stay around
+ ;; after being cleaned-up.
+ ;; I must figure out why they're staying around.
+ _ &type/reset-mappings]
(return &/$Nil))
)))
-(defn ^:private merge-hosts
+(defn ^:private merge-module-states
"(-> Host Host Host)"
[new old]
- (|let [merged-module-states (&/fold (fn [total m-state]
- (|let [[_name _state] m-state]
- (|case _state
- (&/$Cached)
- (&/|put _name _state total)
+ (|let [merged-module-states (&/fold (fn [total new-module]
+ (|let [[_name _module] new-module]
+ (|case (&/get$ &&module/$module-state _module)
+ (&&module/$Cached)
+ (&/|put _name _module total)
- (&/$Compiled)
- (&/|put _name _state total)
+ (&&module/$Compiled)
+ (&/|put _name _module total)
_
total)))
- (&/get$ &/$module-states old)
- (&/get$ &/$module-states new))]
- (->> old
- (&/set$ &/$module-states merged-module-states))))
+ (&/get$ &/$modules old)
+ (&/get$ &/$modules new))]
+ (&/set$ &/$modules merged-module-states old)))
(defn ^:private merge-modules
"(-> Text Module Module Module)"
@@ -618,8 +614,7 @@
(&/get$ &/$modules old)))
(&/set$ &/$seed (max (&/get$ &/$seed new)
(&/get$ &/$seed old)))
- (&/set$ &/$host (merge-hosts (&/get$ &/$host new)
- (&/get$ &/$host old)))))
+ (merge-module-states new)))
(def ^:private get-compiler
(fn [compiler]
@@ -645,7 +640,7 @@
(&/fail-with-loc (str "[Analyser Error] Module can't import itself: " path))
(return nil))
already-compiled? (&&module/exists? path)
- active? (&/active-module? path)
+ active? (&&module/active-module? path)
_ (&/assert! (not active?)
(str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " current-module))
_ (&&module/add-import path)
diff --git a/luxc/src/lux/analyser/module.clj b/luxc/src/lux/analyser/module.clj
index c6a079cab..9df1054c8 100644
--- a/luxc/src/lux/analyser/module.clj
+++ b/luxc/src/lux/analyser/module.clj
@@ -4,13 +4,20 @@
[template :refer [do-template]])
clojure.core.match
clojure.core.match.array
- (lux [base :as & :refer [deftuple |let |do return return* |case]]
+ (lux [base :as & :refer [defvariant deftuple |let |do return return* |case]]
[type :as &type]
[host :as &host])
[lux.host.generics :as &host-generics]
(lux.analyser [meta :as &meta])))
;; [Utils]
+;; ModuleState
+(defvariant
+ ("Active" 0)
+ ("Compiled" 0)
+ ("Cached" 0))
+
+;; Module
(deftuple
["module-hash"
"module-aliases"
@@ -18,7 +25,8 @@
"imports"
"tags"
"types"
- "module-anns"])
+ "module-anns"
+ "module-state"])
(defn ^:private new-module [hash]
(&/T [;; lux;module-hash
@@ -34,9 +42,38 @@
;; "lux;types"
(&/|table)
;; module-anns
- (&/|list)]
+ (&/|list)
+ ;; "module-state"
+ $Active]
))
+(do-template [<flagger> <asker> <tag>]
+ (do (defn <flagger> [module-name]
+ "(-> Text (Lux Unit))"
+ (fn [state]
+ (let [state* (&/update$ &/$modules
+ (fn [modules]
+ (&/|update module-name
+ (fn [=module]
+ (&/set$ $module-state <tag> =module))
+ modules))
+ state)]
+ (&/$Right (&/T [state* &/unit-tag])))))
+ (defn <asker> [module-name]
+ "(-> Text (Lux Bool))"
+ (fn [state]
+ (if-let [=module (->> state (&/get$ &/$modules) (&/|get module-name))]
+ (&/$Right (&/T [state (|case (&/get$ $module-state =module)
+ (<tag>) true
+ _ false)]))
+ (&/$Right (&/T [state false])))
+ )))
+
+ flag-active-module active-module? $Active
+ flag-compiled-module compiled-module? $Compiled
+ flag-cached-module cached-module? $Cached
+ )
+
;; [Exports]
(defn add-import
"(-> Text (Lux Null))"
@@ -396,3 +433,16 @@
_
(&/fail-with-loc "[Analyser Error] No import meta-data.")))
+
+(def tag-groups
+ "(Lux (List [Text (List Text)]))"
+ (|do [module &/get-current-module]
+ (return (&/|map (fn [pair]
+ (|case pair
+ [name [tags exported? _]]
+ (&/T [name (&/|map (fn [tag]
+ (|let [[t-prefix t-name] tag]
+ t-name))
+ tags)])))
+ (&/get$ $types module)))
+ ))
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj
new file mode 100644
index 000000000..9a295b1eb
--- /dev/null
+++ b/luxc/src/lux/analyser/proc/common.clj
@@ -0,0 +1,651 @@
+(ns lux.analyser.proc.common
+ (:require (clojure [template :refer [do-template]])
+ clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [|let |do return* return |case assert!]]
+ [type :as &type])
+ (lux.analyser [base :as &&])))
+
+(defn ^:private analyse-lux-is [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values]
+ =left (&&/analyse-1 analyse $var left)
+ =right (&&/analyse-1 analyse $var right)
+ _ (&type/check exo-type &type/Bool)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["lux" "is"]) (&/|list =left =right) (&/|list)))))))))
+
+(defn ^:private analyse-lux-try [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons op (&/$Nil)) ?values]
+ =op (&&/analyse-1 analyse (&/$AppT &type/IO $var) op)
+ _ (&type/check exo-type (&/$SumT &type/Text ;; lux;Left
+ $var ;; lux;Right
+ ))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list)))))))))
+
+(do-template [<name> <proc> <input-type> <output-type>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
+ =x (&&/analyse-1 analyse <input-type> x)
+ =y (&&/analyse-1 analyse <input-type> y)
+ _ (&type/check exo-type <output-type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list)))))))
+
+ ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool
+ ^:private analyse-text-lt ["text" "<"] &type/Text &type/Bool
+ ^:private analyse-text-append ["text" "append"] &type/Text &type/Text
+ )
+
+(do-template [<name> <proc-name> <output-type>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Cons part (&/$Cons start (&/$Nil)))) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ =part (&&/analyse-1 analyse &type/Text part)
+ =start (&&/analyse-1 analyse &type/Nat start)
+ _ (&type/check exo-type <output-type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" <proc-name>])
+ (&/|list =text =part =start)
+ (&/|list)))))))
+
+ ^:private analyse-text-index "index" (&/$AppT &type/Maybe &type/Nat)
+ ^:private analyse-text-last-index "last-index" (&/$AppT &type/Maybe &type/Nat)
+ )
+
+(defn ^:private analyse-text-contains? [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ =part (&&/analyse-1 analyse &type/Text part)
+ _ (&type/check exo-type &type/Bool)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" "contains?"])
+ (&/|list =text =part)
+ (&/|list)))))))
+
+(defn ^:private analyse-text-clip [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ =from (&&/analyse-1 analyse &type/Nat from)
+ =to (&&/analyse-1 analyse &type/Nat to)
+ _ (&type/check exo-type (&/$AppT &type/Maybe &type/Text))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" "clip"])
+ (&/|list =text =from =to)
+ (&/|list)))))))
+
+(defn ^:private analyse-text-replace-all [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Cons to-find (&/$Cons replace-with (&/$Nil)))) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ =to-find (&&/analyse-1 analyse &type/Text to-find)
+ =replace-with (&&/analyse-1 analyse &type/Text replace-with)
+ _ (&type/check exo-type &type/Text)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" "replace-all"])
+ (&/|list =text =to-find =replace-with)
+ (&/|list)))))))
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Nil)) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ _ (&type/check exo-type &type/Nat)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" <proc>])
+ (&/|list =text)
+ (&/|list)))))))
+
+ ^:private analyse-text-size "size"
+ ^:private analyse-text-hash "hash"
+ )
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Nil)) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ _ (&type/check exo-type &type/Text)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" <proc>])
+ (&/|list =text)
+ (&/|list)))))))
+
+ ^:private analyse-text-trim "trim"
+ ^:private analyse-text-upper-case "upper-case"
+ ^:private analyse-text-lower-case "lower-case"
+ )
+
+(defn ^:private analyse-text-char [analyse exo-type ?values]
+ (|do [:let [(&/$Cons text (&/$Cons idx (&/$Nil))) ?values]
+ =text (&&/analyse-1 analyse &type/Text text)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ _ (&type/check exo-type (&/$AppT &type/Maybe &type/Char))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["text" "char"])
+ (&/|list =text =idx)
+ (&/|list)))))))
+
+(do-template [<name> <op>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values]
+ =mask (&&/analyse-1 analyse &type/Nat mask)
+ =input (&&/analyse-1 analyse &type/Nat input)
+ _ (&type/check exo-type &type/Nat)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["bit" <op>]) (&/|list =input =mask) (&/|list)))))))
+
+ ^:private analyse-bit-and "and"
+ ^:private analyse-bit-or "or"
+ ^:private analyse-bit-xor "xor"
+ )
+
+(defn ^:private analyse-bit-count [analyse exo-type ?values]
+ (|do [:let [(&/$Cons input (&/$Nil)) ?values]
+ =input (&&/analyse-1 analyse &type/Nat input)
+ _ (&type/check exo-type &type/Nat)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list)))))))
+
+(do-template [<name> <op> <type>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values]
+ =shift (&&/analyse-1 analyse &type/Nat shift)
+ =input (&&/analyse-1 analyse <type> input)
+ _ (&type/check exo-type <type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list)))))))
+
+ ^:private analyse-bit-shift-left "shift-left" &type/Nat
+ ^:private analyse-bit-shift-right "shift-right" &type/Int
+ ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat
+ )
+
+(do-template [<name> <proc> <input-type> <output-type>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
+ =x (&&/analyse-1 analyse <input-type> x)
+ =y (&&/analyse-1 analyse <input-type> y)
+ _ (&type/check exo-type <output-type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list)))))))
+
+ ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat
+ ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat
+ ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat
+ ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat
+ ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat
+ ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool
+ ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool
+
+ ^:private analyse-int-add ["int" "+"] &type/Int &type/Int
+ ^:private analyse-int-sub ["int" "-"] &type/Int &type/Int
+ ^:private analyse-int-mul ["int" "*"] &type/Int &type/Int
+ ^:private analyse-int-div ["int" "/"] &type/Int &type/Int
+ ^:private analyse-int-rem ["int" "%"] &type/Int &type/Int
+ ^:private analyse-int-eq ["int" "="] &type/Int &type/Bool
+ ^:private analyse-int-lt ["int" "<"] &type/Int &type/Bool
+
+ ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg
+ ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg
+ ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg
+ ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg
+ ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg
+ ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool
+ ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool
+
+ ^:private analyse-real-add ["real" "+"] &type/Real &type/Real
+ ^:private analyse-real-sub ["real" "-"] &type/Real &type/Real
+ ^:private analyse-real-mul ["real" "*"] &type/Real &type/Real
+ ^:private analyse-real-div ["real" "/"] &type/Real &type/Real
+ ^:private analyse-real-rem ["real" "%"] &type/Real &type/Real
+ ^:private analyse-real-eq ["real" "="] &type/Real &type/Bool
+ ^:private analyse-real-lt ["real" "<"] &type/Real &type/Bool
+
+ ^:private analyse-char-eq ["char" "="] &type/Char &type/Bool
+ ^:private analyse-char-lt ["char" "<"] &type/Char &type/Bool
+ )
+
+(defn ^:private analyse-deg-scale [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
+ =x (&&/analyse-1 analyse &type/Deg x)
+ =y (&&/analyse-1 analyse &type/Nat y)
+ _ (&type/check exo-type &type/Deg)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list)))))))
+
+(do-template [<encode> <encode-op> <decode> <decode-op> <type>]
+ (do (defn <encode> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Nil)) ?values]
+ =x (&&/analyse-1 analyse <type> x)
+ _ (&type/check exo-type &type/Text)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list)))))))
+
+ (let [decode-type (&/$AppT &type/Maybe <type>)]
+ (defn <decode> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Nil)) ?values]
+ =x (&&/analyse-1 analyse &type/Text x)
+ _ (&type/check exo-type decode-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list)))))))))
+
+ ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat
+ ^:private analyse-int-encode ["int" "encode"] ^:private analyse-int-decode ["int" "decode"] &type/Int
+ ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg
+ ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real
+ )
+
+(do-template [<name> <type> <op>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Nil) ?values]
+ _ (&type/check exo-type <type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T <op>) (&/|list) (&/|list)))))))
+
+ ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"]
+ ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"]
+
+ ^:private analyse-int-min-value &type/Int ["int" "min-value"]
+ ^:private analyse-int-max-value &type/Int ["int" "max-value"]
+
+ ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"]
+ ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"]
+
+ ^:private analyse-real-min-value &type/Real ["real" "min-value"]
+ ^:private analyse-real-max-value &type/Real ["real" "max-value"]
+ ^:private analyse-real-not-a-number &type/Real ["real" "not-a-number"]
+ ^:private analyse-real-positive-infinity &type/Real ["real" "positive-infinity"]
+ ^:private analyse-real-negative-infinity &type/Real ["real" "negative-infinity"]
+ )
+
+(do-template [<name> <from-type> <to-type> <op>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons x (&/$Nil)) ?values]
+ =x (&&/analyse-1 analyse <from-type> x)
+ _ (&type/check exo-type <to-type>)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T <op>) (&/|list =x) (&/|list)))))))
+
+ ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"]
+ ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"]
+
+ ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"]
+ ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"]
+
+ ^:private analyse-int-to-real &type/Int &type/Real ["int" "to-real"]
+ ^:private analyse-real-to-int &type/Real &type/Int ["real" "to-int"]
+ ^:private analyse-real-hash &type/Real &type/Nat ["real" "hash"]
+
+ ^:private analyse-char-to-text &type/Char &type/Text ["char" "to-text"]
+
+ ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"]
+ ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"]
+
+ ^:private analyse-io-log &type/Text &/$UnitT ["io" "log"]
+ ^:private analyse-io-error &type/Text &type/Bottom ["io" "error"]
+ ^:private analyse-io-exit &type/Int &type/Bottom ["io" "exit"]
+ )
+
+(defn ^:private analyse-io-current-time [analyse exo-type ?values]
+ (|do [:let [(&/$Nil) ?values]
+ _ (&type/check exo-type &type/Int)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["io" "current-time"]) (&/|list) (&/|list)))))))
+
+(defn ^:private analyse-array-new [analyse exo-type ?values]
+ (|do [:let [(&/$Cons length (&/$Nil)) ?values]
+ =length (&&/analyse-1 analyse &type/Nat length)
+ _ (&type/check exo-type (&/$UnivQ (&/|list) (&type/Array (&/$BoundT 1))))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "new"]) (&/|list =length) (&/|list)))))))
+
+(defn ^:private analyse-array-get [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
+ =array (&&/analyse-1 analyse (&type/Array $var) array)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ _ (&type/check exo-type (&/$AppT &type/Maybe $var))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list)))))))))
+
+(defn ^:private analyse-array-put [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values]
+ :let [array-type (&type/Array $var)]
+ =array (&&/analyse-1 analyse array-type array)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ =elem (&&/analyse-1 analyse $var elem)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "put"]) (&/|list =array =idx =elem) (&/|list)))))))))
+
+(defn ^:private analyse-array-remove [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
+ :let [array-type (&type/Array $var)]
+ =array (&&/analyse-1 analyse array-type array)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "remove"]) (&/|list =array =idx) (&/|list)))))))))
+
+(defn ^:private analyse-array-size [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Nil)) ?values]
+ =array (&&/analyse-1 analyse (&type/Array $var) array)
+ _ (&type/check exo-type &type/Nat)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list)))))))))
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Nil) ?values]
+ _ (&type/check exo-type &type/Real)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["math" <proc>]) (&/|list) (&/|list)))))))
+
+ ^:private analyse-math-e "e"
+ ^:private analyse-math-pi "pi"
+ )
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ =input (&&/analyse-1 analyse &type/Real ?input)
+ _ (&type/check exo-type &type/Real)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["math" <proc>]) (&/|list =input) (&/|list)))))))
+
+ ^:private analyse-math-cos "cos"
+ ^:private analyse-math-sin "sin"
+ ^:private analyse-math-tan "tan"
+ ^:private analyse-math-acos "acos"
+ ^:private analyse-math-asin "asin"
+ ^:private analyse-math-atan "atan"
+ ^:private analyse-math-cosh "cosh"
+ ^:private analyse-math-sinh "sinh"
+ ^:private analyse-math-tanh "tanh"
+ ^:private analyse-math-exp "exp"
+ ^:private analyse-math-log "log"
+ ^:private analyse-math-root2 "root2"
+ ^:private analyse-math-root3 "root3"
+ ^:private analyse-math-ceil "ceil"
+ ^:private analyse-math-floor "floor"
+ ^:private analyse-math-round "round"
+ )
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values]
+ =input (&&/analyse-1 analyse &type/Real ?input)
+ =param (&&/analyse-1 analyse &type/Real ?param)
+ _ (&type/check exo-type &type/Real)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["math" <proc>]) (&/|list =input =param) (&/|list)))))))
+
+ ^:private analyse-math-atan2 "atan2"
+ ^:private analyse-math-pow "pow"
+ )
+
+(defn ^:private analyse-atom-new [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons ?init (&/$Nil)) ?values]
+ =init (&&/analyse-1 analyse $var ?init)
+ _ (&type/check exo-type (&type/Atom $var))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["atom" "new"]) (&/|list =init) (&/|list)))))))))
+
+(defn ^:private analyse-atom-get [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values]
+ =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom)
+ _ (&type/check exo-type $var)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["atom" "get"]) (&/|list =atom) (&/|list)))))))))
+
+(defn ^:private analyse-atom-compare-and-swap [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values]
+ =atom (&&/analyse-1 analyse (&type/Atom $var) ?atom)
+ =old (&&/analyse-1 analyse $var ?old)
+ =new (&&/analyse-1 analyse $var ?new)
+ _ (&type/check exo-type &type/Bool)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["atom" "compare-and-swap"]) (&/|list =atom =old =new) (&/|list)))))))))
+
+(defn ^:private analyse-process-concurrency-level [analyse exo-type ?values]
+ (|do [:let [(&/$Nil) ?values]
+ _ (&type/check exo-type &type/Nat)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["process" "concurrency-level"]) (&/|list) (&/|list)))))))
+
+(defn ^:private analyse-process-future [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values]
+ =procedure (&&/analyse-1 analyse (&/$AppT &type/IO &type/Top) ?procedure)
+ _ (&type/check exo-type &/$UnitT)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["process" "future"]) (&/|list =procedure) (&/|list)))))))
+
+(defn ^:private analyse-process-schedule [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values]
+ =milliseconds (&&/analyse-1 analyse &type/Nat ?milliseconds)
+ =procedure (&&/analyse-1 analyse (&/$AppT &type/IO &type/Top) ?procedure)
+ _ (&type/check exo-type &/$UnitT)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["process" "schedule"]) (&/|list =milliseconds =procedure) (&/|list)))))))
+
+(defn analyse-proc [analyse exo-type category proc ?values]
+ (case category
+ "lux"
+ (case proc
+ "is" (analyse-lux-is analyse exo-type ?values)
+ "try" (analyse-lux-try analyse exo-type ?values))
+
+ "io"
+ (case proc
+ "log" (analyse-io-log analyse exo-type ?values)
+ "error" (analyse-io-error analyse exo-type ?values)
+ "exit" (analyse-io-exit analyse exo-type ?values)
+ "current-time" (analyse-io-current-time analyse exo-type ?values)
+ )
+
+ "text"
+ (case proc
+ "=" (analyse-text-eq analyse exo-type ?values)
+ "<" (analyse-text-lt analyse exo-type ?values)
+ "append" (analyse-text-append analyse exo-type ?values)
+ "clip" (analyse-text-clip analyse exo-type ?values)
+ "index" (analyse-text-index analyse exo-type ?values)
+ "last-index" (analyse-text-last-index analyse exo-type ?values)
+ "size" (analyse-text-size analyse exo-type ?values)
+ "hash" (analyse-text-hash analyse exo-type ?values)
+ "replace-all" (analyse-text-replace-all analyse exo-type ?values)
+ "trim" (analyse-text-trim analyse exo-type ?values)
+ "char" (analyse-text-char analyse exo-type ?values)
+ "upper-case" (analyse-text-upper-case analyse exo-type ?values)
+ "lower-case" (analyse-text-lower-case analyse exo-type ?values)
+ "contains?" (analyse-text-contains? analyse exo-type ?values)
+ )
+
+ "bit"
+ (case proc
+ "count" (analyse-bit-count analyse exo-type ?values)
+ "and" (analyse-bit-and analyse exo-type ?values)
+ "or" (analyse-bit-or analyse exo-type ?values)
+ "xor" (analyse-bit-xor analyse exo-type ?values)
+ "shift-left" (analyse-bit-shift-left analyse exo-type ?values)
+ "shift-right" (analyse-bit-shift-right analyse exo-type ?values)
+ "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values))
+
+ "array"
+ (case proc
+ "new" (analyse-array-new analyse exo-type ?values)
+ "get" (analyse-array-get analyse exo-type ?values)
+ "put" (analyse-array-put analyse exo-type ?values)
+ "remove" (analyse-array-remove analyse exo-type ?values)
+ "size" (analyse-array-size analyse exo-type ?values))
+
+ "nat"
+ (case proc
+ "+" (analyse-nat-add analyse exo-type ?values)
+ "-" (analyse-nat-sub analyse exo-type ?values)
+ "*" (analyse-nat-mul analyse exo-type ?values)
+ "/" (analyse-nat-div analyse exo-type ?values)
+ "%" (analyse-nat-rem analyse exo-type ?values)
+ "=" (analyse-nat-eq analyse exo-type ?values)
+ "<" (analyse-nat-lt analyse exo-type ?values)
+ "encode" (analyse-nat-encode analyse exo-type ?values)
+ "decode" (analyse-nat-decode analyse exo-type ?values)
+ "min-value" (analyse-nat-min-value analyse exo-type ?values)
+ "max-value" (analyse-nat-max-value analyse exo-type ?values)
+ "to-int" (analyse-nat-to-int analyse exo-type ?values)
+ "to-char" (analyse-nat-to-char analyse exo-type ?values)
+ )
+
+ "int"
+ (case proc
+ "+" (analyse-int-add analyse exo-type ?values)
+ "-" (analyse-int-sub analyse exo-type ?values)
+ "*" (analyse-int-mul analyse exo-type ?values)
+ "/" (analyse-int-div analyse exo-type ?values)
+ "%" (analyse-int-rem analyse exo-type ?values)
+ "=" (analyse-int-eq analyse exo-type ?values)
+ "<" (analyse-int-lt analyse exo-type ?values)
+ "encode" (analyse-int-encode analyse exo-type ?values)
+ "decode" (analyse-int-decode analyse exo-type ?values)
+ "min-value" (analyse-int-min-value analyse exo-type ?values)
+ "max-value" (analyse-int-max-value analyse exo-type ?values)
+ "to-nat" (analyse-int-to-nat analyse exo-type ?values)
+ "to-real" (analyse-int-to-real analyse exo-type ?values)
+ )
+
+ "deg"
+ (case proc
+ "+" (analyse-deg-add analyse exo-type ?values)
+ "-" (analyse-deg-sub analyse exo-type ?values)
+ "*" (analyse-deg-mul analyse exo-type ?values)
+ "/" (analyse-deg-div analyse exo-type ?values)
+ "%" (analyse-deg-rem analyse exo-type ?values)
+ "=" (analyse-deg-eq analyse exo-type ?values)
+ "<" (analyse-deg-lt analyse exo-type ?values)
+ "encode" (analyse-deg-encode analyse exo-type ?values)
+ "decode" (analyse-deg-decode analyse exo-type ?values)
+ "min-value" (analyse-deg-min-value analyse exo-type ?values)
+ "max-value" (analyse-deg-max-value analyse exo-type ?values)
+ "to-real" (analyse-deg-to-real analyse exo-type ?values)
+ "scale" (analyse-deg-scale analyse exo-type ?values)
+ )
+
+ "real"
+ (case proc
+ "+" (analyse-real-add analyse exo-type ?values)
+ "-" (analyse-real-sub analyse exo-type ?values)
+ "*" (analyse-real-mul analyse exo-type ?values)
+ "/" (analyse-real-div analyse exo-type ?values)
+ "%" (analyse-real-rem analyse exo-type ?values)
+ "=" (analyse-real-eq analyse exo-type ?values)
+ "<" (analyse-real-lt analyse exo-type ?values)
+ "encode" (analyse-real-encode analyse exo-type ?values)
+ "decode" (analyse-real-decode analyse exo-type ?values)
+ "min-value" (analyse-real-min-value analyse exo-type ?values)
+ "max-value" (analyse-real-max-value analyse exo-type ?values)
+ "not-a-number" (analyse-real-not-a-number analyse exo-type ?values)
+ "positive-infinity" (analyse-real-positive-infinity analyse exo-type ?values)
+ "negative-infinity" (analyse-real-negative-infinity analyse exo-type ?values)
+ "to-deg" (analyse-real-to-deg analyse exo-type ?values)
+ "to-int" (analyse-real-to-int analyse exo-type ?values)
+ "hash" (analyse-real-hash analyse exo-type ?values)
+ )
+
+ "char"
+ (case proc
+ "=" (analyse-char-eq analyse exo-type ?values)
+ "<" (analyse-char-lt analyse exo-type ?values)
+ "to-text" (analyse-char-to-text analyse exo-type ?values)
+ "to-nat" (analyse-char-to-nat analyse exo-type ?values)
+ )
+
+ "math"
+ (case proc
+ "e" (analyse-math-e analyse exo-type ?values)
+ "pi" (analyse-math-pi analyse exo-type ?values)
+ "cos" (analyse-math-cos analyse exo-type ?values)
+ "sin" (analyse-math-sin analyse exo-type ?values)
+ "tan" (analyse-math-tan analyse exo-type ?values)
+ "acos" (analyse-math-acos analyse exo-type ?values)
+ "asin" (analyse-math-asin analyse exo-type ?values)
+ "atan" (analyse-math-atan analyse exo-type ?values)
+ "cosh" (analyse-math-cosh analyse exo-type ?values)
+ "sinh" (analyse-math-sinh analyse exo-type ?values)
+ "tanh" (analyse-math-tanh analyse exo-type ?values)
+ "exp" (analyse-math-exp analyse exo-type ?values)
+ "log" (analyse-math-log analyse exo-type ?values)
+ "root2" (analyse-math-root2 analyse exo-type ?values)
+ "root3" (analyse-math-root3 analyse exo-type ?values)
+ "ceil" (analyse-math-ceil analyse exo-type ?values)
+ "floor" (analyse-math-floor analyse exo-type ?values)
+ "round" (analyse-math-round analyse exo-type ?values)
+ "atan2" (analyse-math-atan2 analyse exo-type ?values)
+ "pow" (analyse-math-pow analyse exo-type ?values)
+ )
+
+ "atom"
+ (case proc
+ "new" (analyse-atom-new analyse exo-type ?values)
+ "get" (analyse-atom-get analyse exo-type ?values)
+ "compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values)
+ )
+
+ "process"
+ (case proc
+ "concurrency-level" (analyse-process-concurrency-level analyse exo-type ?values)
+ "future" (analyse-process-future analyse exo-type ?values)
+ "schedule" (analyse-process-schedule analyse exo-type ?values)
+ )
+
+ ;; else
+ (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))
diff --git a/luxc/src/lux/analyser/proc/js.clj b/luxc/src/lux/analyser/proc/js.clj
new file mode 100644
index 000000000..2d36dd0d9
--- /dev/null
+++ b/luxc/src/lux/analyser/proc/js.clj
@@ -0,0 +1,93 @@
+(ns lux.analyser.proc.js
+ (:require (clojure [template :refer [do-template]]
+ [string :as string])
+ clojure.core.match
+ clojure.core.match.array
+ (lux [base :as & :refer [|let |do return* return |case assert!]]
+ [type :as &type])
+ (lux.analyser [base :as &&])))
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?function ?args) ?values]
+ =function (&&/analyse-1 analyse (&/$HostT "function" &/$Nil) ?function)
+ =args (&/map% (partial &&/analyse-1+ analyse) ?args)
+ _ (&type/check exo-type (&/$HostT "object" &/$Nil))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["js" <proc>]) (&/$Cons =function =args) (&/|list)))))))
+
+ ^:private analyse-js-new "new"
+ ^:private analyse-js-call "call"
+ )
+
+(defn ^:private analyse-js-object-call [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?object (&/$Cons ?field ?args)) ?values]
+ =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object)
+ =field (&&/analyse-1 analyse &type/Text ?field)
+ =args (&/map% (partial &&/analyse-1+ analyse) ?args)
+ _ (&type/check exo-type (&/$HostT "object" &/$Nil))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["js" "object-call"]) (&/$Cons =object (&/$Cons =field =args)) (&/|list)))))))
+
+(defn ^:private analyse-js-ref [analyse exo-type ?values]
+ (|do [:let [(&/$Cons [_ (&/$TextS ?ref-name)] (&/$Nil)) ?values]
+ _ (&type/check exo-type (&/$HostT "object" &/$Nil))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["js" "ref"]) (&/|list) (&/|list ?ref-name)))))))
+
+(do-template [<name> <proc>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Nil))) ?values]
+ =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object)
+ =field (&&/analyse-1 analyse &type/Text ?field)
+ _ (&type/check exo-type (&/$HostT "object" &/$Nil))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["js" <proc>]) (&/|list =object =field) (&/|list)))))))
+
+ ^:private analyse-js-get-field "get-field"
+ ^:private analyse-js-delete-field "delete-field"
+ )
+
+(defn ^:private analyse-js-set-field [analyse exo-type ?values]
+ (|do [:let [(&/$Cons ?object (&/$Cons ?field (&/$Cons ?value (&/$Nil)))) ?values]
+ =object (&&/analyse-1 analyse (&/$HostT "object" &/$Nil) ?object)
+ =field (&&/analyse-1 analyse &type/Text ?field)
+ =value (&&/analyse-1+ analyse ?value)
+ _ (&type/check exo-type (&/$HostT "object" &/$Nil))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["js" "set-field"]) (&/|list =object =field =value) (&/|list)))))))
+
+(do-template [<name> <proc> <type>]
+ (defn <name> [analyse exo-type ?values]
+ (|do [:let [(&/$Nil) ?values]
+ :let [output-type (&/$HostT <type> &/$Nil)]
+ _ (&type/check exo-type output-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["js" <proc>]) (&/|list) (&/|list)))))))
+
+ ^:private analyse-js-object "object" "object"
+ ^:private analyse-js-null "null" "object"
+ ^:private analyse-js-undefined "undefined" "undefined"
+ )
+
+(defn analyse-host [analyse exo-type proc ?values]
+ (case proc
+ "new" (analyse-js-new analyse exo-type ?values)
+ "call" (analyse-js-call analyse exo-type ?values)
+ "object-call" (analyse-js-object-call analyse exo-type ?values)
+ "ref" (analyse-js-ref analyse exo-type ?values)
+ "object" (analyse-js-object analyse exo-type ?values)
+ "get-field" (analyse-js-get-field analyse exo-type ?values)
+ "set-field" (analyse-js-set-field analyse exo-type ?values)
+ "delete-field" (analyse-js-delete-field analyse exo-type ?values)
+ "null" (analyse-js-null analyse exo-type ?values)
+ "undefined" (analyse-js-undefined analyse exo-type ?values)
+ ;; else
+ (&/fail-with-loc (str "[Analyser Error] Unknown JS procedure: " proc)))
+ )
diff --git a/luxc/src/lux/analyser/host.clj b/luxc/src/lux/analyser/proc/jvm.clj
index d89de457b..72b871686 100644
--- a/luxc/src/lux/analyser/host.clj
+++ b/luxc/src/lux/analyser/proc/jvm.clj
@@ -1,4 +1,4 @@
-(ns lux.analyser.host
+(ns lux.analyser.proc.jvm
(:require (clojure [template :refer [do-template]]
[string :as string])
clojure.core.match
@@ -15,7 +15,7 @@
[lambda :as &&lambda]
[env :as &&env]
[parser :as &&a-parser])
- [lux.compiler.base :as &c!base])
+ [lux.compiler.jvm.base :as &c!base])
(:import (java.lang.reflect Type TypeVariable)))
;; [Utils]
@@ -25,7 +25,6 @@
(fn [state]
(|let [exceptions (&/|map #(Class/forName % true class-loader) exceptions*)
catching (->> state
- (&/get$ &/$host)
(&/get$ &/$catching)
(&/|map #(Class/forName % true class-loader)))]
(if-let [missing-ex (&/fold (fn [prev ^Class now]
@@ -53,14 +52,14 @@
(defn ^:private with-catches [catches body]
"(All [a] (-> (List Text) (Lux a) (Lux a)))"
(fn [state]
- (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching))
- state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))]
+ (let [old-catches (&/get$ &/$catching state)
+ state* (&/update$ &/$catching (partial &/|++ catches) state)]
(|case (&/run-state body state*)
(&/$Left msg)
(&/$Left msg)
(&/$Right state** output)
- (&/$Right (&/T [(->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %)))
+ (&/$Right (&/T [(&/set$ &/$catching old-catches state**)
output]))))
))
@@ -882,46 +881,6 @@
(return (&/|list (&&/|meta output-type _cursor
(&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type)))))))
-(let [length-type &type/Nat
- idx-type &type/Nat]
- (defn ^:private analyse-array-new [analyse exo-type ?values]
- (|do [:let [(&/$Cons length (&/$Nil)) ?values]
- :let [gclass (&/$GenericClass "java.lang.Object" (&/|list))
- array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))]
- gtype-env &/get-type-env
- =length (&&/analyse-1 analyse length-type length)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env)))))))
-
- (defn ^:private analyse-array-get [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- [arr-class arr-params] (ensure-object (&&/expr-type* =array))
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list)))))))
-
- (defn ^:private analyse-array-remove [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- :let [array-type (&&/expr-type* =array)]
- [arr-class arr-params] (ensure-object array-type)
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _cursor &/cursor
- :let [=elem (&&/|meta inner-arr-type _cursor
- (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))]
- _ (&type/check exo-type array-type)]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list))))))))
-
(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods]
(|do [module &/get-module-name
_ (compile-interface interface-decl supers =anns =methods)
@@ -1002,359 +961,144 @@
)))
))))
-(do-template [<name> <op>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values]
- =mask (&&/analyse-1 analyse &type/Nat mask)
- =input (&&/analyse-1 analyse &type/Nat input)
- _ (&type/check exo-type &type/Nat)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["bit" <op>]) (&/|list =input =mask) (&/|list)))))))
-
- ^:private analyse-bit-and "and"
- ^:private analyse-bit-or "or"
- ^:private analyse-bit-xor "xor"
- )
-
-(defn ^:private analyse-bit-count [analyse exo-type ?values]
- (|do [:let [(&/$Cons input (&/$Nil)) ?values]
- =input (&&/analyse-1 analyse &type/Nat input)
- _ (&type/check exo-type &type/Nat)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list)))))))
-
-(do-template [<name> <op> <type>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values]
- =shift (&&/analyse-1 analyse &type/Nat shift)
- =input (&&/analyse-1 analyse <type> input)
- _ (&type/check exo-type <type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list)))))))
-
- ^:private analyse-bit-shift-left "shift-left" &type/Nat
- ^:private analyse-bit-shift-right "shift-right" &type/Int
- ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat
- )
-
-(defn ^:private analyse-lux-== [analyse exo-type ?values]
- (&type/with-var
- (fn [$var]
- (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values]
- =left (&&/analyse-1 analyse $var left)
- =right (&&/analyse-1 analyse $var right)
- _ (&type/check exo-type &type/Bool)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list)))))))))
-
-(do-template [<name> <proc> <input-type> <output-type>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
- =x (&&/analyse-1 analyse <input-type> x)
- =y (&&/analyse-1 analyse <input-type> y)
- _ (&type/check exo-type <output-type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta <output-type> _cursor
- (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list)))))))
-
- ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat
- ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat
- ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat
- ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat
- ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat
- ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool
- ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool
-
- ^:private analyse-deg-add ["deg" "+"] &type/Deg &type/Deg
- ^:private analyse-deg-sub ["deg" "-"] &type/Deg &type/Deg
- ^:private analyse-deg-mul ["deg" "*"] &type/Deg &type/Deg
- ^:private analyse-deg-div ["deg" "/"] &type/Deg &type/Deg
- ^:private analyse-deg-rem ["deg" "%"] &type/Deg &type/Deg
- ^:private analyse-deg-eq ["deg" "="] &type/Deg &type/Bool
- ^:private analyse-deg-lt ["deg" "<"] &type/Deg &type/Bool
- )
-
-(defn ^:private analyse-deg-scale [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values]
- =x (&&/analyse-1 analyse &type/Deg x)
- =y (&&/analyse-1 analyse &type/Nat y)
- _ (&type/check exo-type &type/Deg)
- _cursor &/cursor]
- (return (&/|list (&&/|meta &type/Deg _cursor
- (&&/$proc (&/T ["deg" "scale"]) (&/|list =x =y) (&/|list)))))))
-
-(do-template [<encode> <encode-op> <decode> <decode-op> <type>]
- (do (defn <encode> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Nil)) ?values]
- =x (&&/analyse-1 analyse <type> x)
- _ (&type/check exo-type &type/Text)
- _cursor &/cursor]
- (return (&/|list (&&/|meta &type/Text _cursor
- (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list)))))))
-
- (let [decode-type (&/$AppT &type/Maybe <type>)]
- (defn <decode> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Nil)) ?values]
- =x (&&/analyse-1 analyse &type/Text x)
- _ (&type/check exo-type decode-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta decode-type _cursor
- (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list)))))))))
-
- ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat
- ^:private analyse-deg-encode ["deg" "encode"] ^:private analyse-deg-decode ["deg" "decode"] &type/Deg
- )
-
-(do-template [<name> <type> <op>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Nil) ?values]
- _ (&type/check exo-type <type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta <type> _cursor
- (&&/$proc (&/T <op>) (&/|list) (&/|list)))))))
-
- ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"]
- ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"]
-
- ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"]
- ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"]
- )
-
-(do-template [<name> <from-type> <to-type> <op>]
- (defn <name> [analyse exo-type ?values]
- (|do [:let [(&/$Cons x (&/$Nil)) ?values]
- =x (&&/analyse-1 analyse <from-type> x)
- _ (&type/check exo-type <to-type>)
- _cursor &/cursor]
- (return (&/|list (&&/|meta <to-type> _cursor
- (&&/$proc (&/T <op>) (&/|list =x) (&/|list)))))))
-
- ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"]
- ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"]
- ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"]
- ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"]
-
- ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"]
- ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"]
- )
-
-(defn analyse-host [analyse exo-type compilers category proc ?values]
- (|let [[_ _ compile-class compile-interface] compilers]
- (case category
- "lux"
- (case proc
- "==" (analyse-lux-== analyse exo-type ?values))
-
- "bit"
- (case proc
- "count" (analyse-bit-count analyse exo-type ?values)
- "and" (analyse-bit-and analyse exo-type ?values)
- "or" (analyse-bit-or analyse exo-type ?values)
- "xor" (analyse-bit-xor analyse exo-type ?values)
- "shift-left" (analyse-bit-shift-left analyse exo-type ?values)
- "shift-right" (analyse-bit-shift-right analyse exo-type ?values)
- "unsigned-shift-right" (analyse-bit-unsigned-shift-right analyse exo-type ?values))
-
- "array"
- (case proc
- "new" (analyse-array-new analyse exo-type ?values)
- "get" (analyse-array-get analyse exo-type ?values)
- "put" (analyse-jvm-aastore analyse exo-type ?values)
- "remove" (analyse-array-remove analyse exo-type ?values)
- "size" (analyse-jvm-arraylength analyse exo-type ?values))
-
- "nat"
- (case proc
- "+" (analyse-nat-add analyse exo-type ?values)
- "-" (analyse-nat-sub analyse exo-type ?values)
- "*" (analyse-nat-mul analyse exo-type ?values)
- "/" (analyse-nat-div analyse exo-type ?values)
- "%" (analyse-nat-rem analyse exo-type ?values)
- "=" (analyse-nat-eq analyse exo-type ?values)
- "<" (analyse-nat-lt analyse exo-type ?values)
- "encode" (analyse-nat-encode analyse exo-type ?values)
- "decode" (analyse-nat-decode analyse exo-type ?values)
- "min-value" (analyse-nat-min-value analyse exo-type ?values)
- "max-value" (analyse-nat-max-value analyse exo-type ?values)
- "to-int" (analyse-nat-to-int analyse exo-type ?values)
- "to-char" (analyse-nat-to-char analyse exo-type ?values)
- )
-
- "deg"
- (case proc
- "+" (analyse-deg-add analyse exo-type ?values)
- "-" (analyse-deg-sub analyse exo-type ?values)
- "*" (analyse-deg-mul analyse exo-type ?values)
- "/" (analyse-deg-div analyse exo-type ?values)
- "%" (analyse-deg-rem analyse exo-type ?values)
- "=" (analyse-deg-eq analyse exo-type ?values)
- "<" (analyse-deg-lt analyse exo-type ?values)
- "encode" (analyse-deg-encode analyse exo-type ?values)
- "decode" (analyse-deg-decode analyse exo-type ?values)
- "min-value" (analyse-deg-min-value analyse exo-type ?values)
- "max-value" (analyse-deg-max-value analyse exo-type ?values)
- "to-real" (analyse-deg-to-real analyse exo-type ?values)
- "scale" (analyse-deg-scale analyse exo-type ?values)
- )
-
- "int"
- (case proc
- "to-nat" (analyse-int-to-nat analyse exo-type ?values)
- )
-
- "real"
- (case proc
- "to-deg" (analyse-real-to-deg analyse exo-type ?values)
- )
-
- "char"
- (case proc
- "to-nat" (analyse-char-to-nat analyse exo-type ?values)
- )
-
- "jvm"
- (case proc
- "synchronized" (analyse-jvm-synchronized analyse exo-type ?values)
- "load-class" (analyse-jvm-load-class analyse exo-type ?values)
- "try" (analyse-jvm-try analyse exo-type ?values)
- "throw" (analyse-jvm-throw analyse exo-type ?values)
- "null?" (analyse-jvm-null? analyse exo-type ?values)
- "null" (analyse-jvm-null analyse exo-type ?values)
- "anewarray" (analyse-jvm-anewarray analyse exo-type ?values)
- "aaload" (analyse-jvm-aaload analyse exo-type ?values)
- "aastore" (analyse-jvm-aastore analyse exo-type ?values)
- "arraylength" (analyse-jvm-arraylength analyse exo-type ?values)
- "znewarray" (analyse-jvm-znewarray analyse exo-type ?values)
- "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values)
- "snewarray" (analyse-jvm-snewarray analyse exo-type ?values)
- "inewarray" (analyse-jvm-inewarray analyse exo-type ?values)
- "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values)
- "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values)
- "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values)
- "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values)
- "iadd" (analyse-jvm-iadd analyse exo-type ?values)
- "isub" (analyse-jvm-isub analyse exo-type ?values)
- "imul" (analyse-jvm-imul analyse exo-type ?values)
- "idiv" (analyse-jvm-idiv analyse exo-type ?values)
- "irem" (analyse-jvm-irem analyse exo-type ?values)
- "ieq" (analyse-jvm-ieq analyse exo-type ?values)
- "ilt" (analyse-jvm-ilt analyse exo-type ?values)
- "igt" (analyse-jvm-igt analyse exo-type ?values)
- "ceq" (analyse-jvm-ceq analyse exo-type ?values)
- "clt" (analyse-jvm-clt analyse exo-type ?values)
- "cgt" (analyse-jvm-cgt analyse exo-type ?values)
- "ladd" (analyse-jvm-ladd analyse exo-type ?values)
- "lsub" (analyse-jvm-lsub analyse exo-type ?values)
- "lmul" (analyse-jvm-lmul analyse exo-type ?values)
- "ldiv" (analyse-jvm-ldiv analyse exo-type ?values)
- "lrem" (analyse-jvm-lrem analyse exo-type ?values)
- "leq" (analyse-jvm-leq analyse exo-type ?values)
- "llt" (analyse-jvm-llt analyse exo-type ?values)
- "lgt" (analyse-jvm-lgt analyse exo-type ?values)
- "fadd" (analyse-jvm-fadd analyse exo-type ?values)
- "fsub" (analyse-jvm-fsub analyse exo-type ?values)
- "fmul" (analyse-jvm-fmul analyse exo-type ?values)
- "fdiv" (analyse-jvm-fdiv analyse exo-type ?values)
- "frem" (analyse-jvm-frem analyse exo-type ?values)
- "feq" (analyse-jvm-feq analyse exo-type ?values)
- "flt" (analyse-jvm-flt analyse exo-type ?values)
- "fgt" (analyse-jvm-fgt analyse exo-type ?values)
- "dadd" (analyse-jvm-dadd analyse exo-type ?values)
- "dsub" (analyse-jvm-dsub analyse exo-type ?values)
- "dmul" (analyse-jvm-dmul analyse exo-type ?values)
- "ddiv" (analyse-jvm-ddiv analyse exo-type ?values)
- "drem" (analyse-jvm-drem analyse exo-type ?values)
- "deq" (analyse-jvm-deq analyse exo-type ?values)
- "dlt" (analyse-jvm-dlt analyse exo-type ?values)
- "dgt" (analyse-jvm-dgt analyse exo-type ?values)
- "iand" (analyse-jvm-iand analyse exo-type ?values)
- "ior" (analyse-jvm-ior analyse exo-type ?values)
- "ixor" (analyse-jvm-ixor analyse exo-type ?values)
- "ishl" (analyse-jvm-ishl analyse exo-type ?values)
- "ishr" (analyse-jvm-ishr analyse exo-type ?values)
- "iushr" (analyse-jvm-iushr analyse exo-type ?values)
- "land" (analyse-jvm-land analyse exo-type ?values)
- "lor" (analyse-jvm-lor analyse exo-type ?values)
- "lxor" (analyse-jvm-lxor analyse exo-type ?values)
- "lshl" (analyse-jvm-lshl analyse exo-type ?values)
- "lshr" (analyse-jvm-lshr analyse exo-type ?values)
- "lushr" (analyse-jvm-lushr analyse exo-type ?values)
- "d2f" (analyse-jvm-d2f analyse exo-type ?values)
- "d2i" (analyse-jvm-d2i analyse exo-type ?values)
- "d2l" (analyse-jvm-d2l analyse exo-type ?values)
- "f2d" (analyse-jvm-f2d analyse exo-type ?values)
- "f2i" (analyse-jvm-f2i analyse exo-type ?values)
- "f2l" (analyse-jvm-f2l analyse exo-type ?values)
- "i2b" (analyse-jvm-i2b analyse exo-type ?values)
- "i2c" (analyse-jvm-i2c analyse exo-type ?values)
- "i2d" (analyse-jvm-i2d analyse exo-type ?values)
- "i2f" (analyse-jvm-i2f analyse exo-type ?values)
- "i2l" (analyse-jvm-i2l analyse exo-type ?values)
- "i2s" (analyse-jvm-i2s analyse exo-type ?values)
- "l2d" (analyse-jvm-l2d analyse exo-type ?values)
- "l2f" (analyse-jvm-l2f analyse exo-type ?values)
- "l2i" (analyse-jvm-l2i analyse exo-type ?values)
- "l2s" (analyse-jvm-l2s analyse exo-type ?values)
- "l2b" (analyse-jvm-l2b analyse exo-type ?values)
- "c2b" (analyse-jvm-c2b analyse exo-type ?values)
- "c2s" (analyse-jvm-c2s analyse exo-type ?values)
- "c2i" (analyse-jvm-c2i analyse exo-type ?values)
- "c2l" (analyse-jvm-c2l analyse exo-type ?values)
- "b2l" (analyse-jvm-b2l analyse exo-type ?values)
- "s2l" (analyse-jvm-s2l analyse exo-type ?values)
- ;; else
- (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))
- (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)]
- (|do [[_module _line _column] &/cursor]
- (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code
- (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def]
- (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods)))))
-
- (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)]
- (|do [[_module _line _column] &/cursor]
- (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code
- (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def]
- (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)))))
-
- (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)]
- (|do [[_module _line _column] &/cursor]
- (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code
- (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def]
- (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods)))))
-
- (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)]
- (analyse-jvm-instanceof analyse exo-type _class ?values))
-
- (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)]
- (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)]
- (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
-
- (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-getstatic analyse exo-type _class _field ?values))
-
- (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-getfield analyse exo-type _class _field ?values))
-
- (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-putstatic analyse exo-type _class _field ?values))
-
- (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)]
- (analyse-jvm-putfield analyse exo-type _class _field ?values))))
-
+(defn analyse-host [analyse exo-type compilers proc ?values]
+ (|let [[_ _ _ compile-class compile-interface] compilers]
+ (case proc
+ "synchronized" (analyse-jvm-synchronized analyse exo-type ?values)
+ "load-class" (analyse-jvm-load-class analyse exo-type ?values)
+ "try" (analyse-jvm-try analyse exo-type ?values)
+ "throw" (analyse-jvm-throw analyse exo-type ?values)
+ "null?" (analyse-jvm-null? analyse exo-type ?values)
+ "null" (analyse-jvm-null analyse exo-type ?values)
+ "anewarray" (analyse-jvm-anewarray analyse exo-type ?values)
+ "aaload" (analyse-jvm-aaload analyse exo-type ?values)
+ "aastore" (analyse-jvm-aastore analyse exo-type ?values)
+ "arraylength" (analyse-jvm-arraylength analyse exo-type ?values)
+ "znewarray" (analyse-jvm-znewarray analyse exo-type ?values)
+ "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values)
+ "snewarray" (analyse-jvm-snewarray analyse exo-type ?values)
+ "inewarray" (analyse-jvm-inewarray analyse exo-type ?values)
+ "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values)
+ "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values)
+ "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values)
+ "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values)
+ "iadd" (analyse-jvm-iadd analyse exo-type ?values)
+ "isub" (analyse-jvm-isub analyse exo-type ?values)
+ "imul" (analyse-jvm-imul analyse exo-type ?values)
+ "idiv" (analyse-jvm-idiv analyse exo-type ?values)
+ "irem" (analyse-jvm-irem analyse exo-type ?values)
+ "ieq" (analyse-jvm-ieq analyse exo-type ?values)
+ "ilt" (analyse-jvm-ilt analyse exo-type ?values)
+ "igt" (analyse-jvm-igt analyse exo-type ?values)
+ "ceq" (analyse-jvm-ceq analyse exo-type ?values)
+ "clt" (analyse-jvm-clt analyse exo-type ?values)
+ "cgt" (analyse-jvm-cgt analyse exo-type ?values)
+ "ladd" (analyse-jvm-ladd analyse exo-type ?values)
+ "lsub" (analyse-jvm-lsub analyse exo-type ?values)
+ "lmul" (analyse-jvm-lmul analyse exo-type ?values)
+ "ldiv" (analyse-jvm-ldiv analyse exo-type ?values)
+ "lrem" (analyse-jvm-lrem analyse exo-type ?values)
+ "leq" (analyse-jvm-leq analyse exo-type ?values)
+ "llt" (analyse-jvm-llt analyse exo-type ?values)
+ "lgt" (analyse-jvm-lgt analyse exo-type ?values)
+ "fadd" (analyse-jvm-fadd analyse exo-type ?values)
+ "fsub" (analyse-jvm-fsub analyse exo-type ?values)
+ "fmul" (analyse-jvm-fmul analyse exo-type ?values)
+ "fdiv" (analyse-jvm-fdiv analyse exo-type ?values)
+ "frem" (analyse-jvm-frem analyse exo-type ?values)
+ "feq" (analyse-jvm-feq analyse exo-type ?values)
+ "flt" (analyse-jvm-flt analyse exo-type ?values)
+ "fgt" (analyse-jvm-fgt analyse exo-type ?values)
+ "dadd" (analyse-jvm-dadd analyse exo-type ?values)
+ "dsub" (analyse-jvm-dsub analyse exo-type ?values)
+ "dmul" (analyse-jvm-dmul analyse exo-type ?values)
+ "ddiv" (analyse-jvm-ddiv analyse exo-type ?values)
+ "drem" (analyse-jvm-drem analyse exo-type ?values)
+ "deq" (analyse-jvm-deq analyse exo-type ?values)
+ "dlt" (analyse-jvm-dlt analyse exo-type ?values)
+ "dgt" (analyse-jvm-dgt analyse exo-type ?values)
+ "iand" (analyse-jvm-iand analyse exo-type ?values)
+ "ior" (analyse-jvm-ior analyse exo-type ?values)
+ "ixor" (analyse-jvm-ixor analyse exo-type ?values)
+ "ishl" (analyse-jvm-ishl analyse exo-type ?values)
+ "ishr" (analyse-jvm-ishr analyse exo-type ?values)
+ "iushr" (analyse-jvm-iushr analyse exo-type ?values)
+ "land" (analyse-jvm-land analyse exo-type ?values)
+ "lor" (analyse-jvm-lor analyse exo-type ?values)
+ "lxor" (analyse-jvm-lxor analyse exo-type ?values)
+ "lshl" (analyse-jvm-lshl analyse exo-type ?values)
+ "lshr" (analyse-jvm-lshr analyse exo-type ?values)
+ "lushr" (analyse-jvm-lushr analyse exo-type ?values)
+ "d2f" (analyse-jvm-d2f analyse exo-type ?values)
+ "d2i" (analyse-jvm-d2i analyse exo-type ?values)
+ "d2l" (analyse-jvm-d2l analyse exo-type ?values)
+ "f2d" (analyse-jvm-f2d analyse exo-type ?values)
+ "f2i" (analyse-jvm-f2i analyse exo-type ?values)
+ "f2l" (analyse-jvm-f2l analyse exo-type ?values)
+ "i2b" (analyse-jvm-i2b analyse exo-type ?values)
+ "i2c" (analyse-jvm-i2c analyse exo-type ?values)
+ "i2d" (analyse-jvm-i2d analyse exo-type ?values)
+ "i2f" (analyse-jvm-i2f analyse exo-type ?values)
+ "i2l" (analyse-jvm-i2l analyse exo-type ?values)
+ "i2s" (analyse-jvm-i2s analyse exo-type ?values)
+ "l2d" (analyse-jvm-l2d analyse exo-type ?values)
+ "l2f" (analyse-jvm-l2f analyse exo-type ?values)
+ "l2i" (analyse-jvm-l2i analyse exo-type ?values)
+ "l2s" (analyse-jvm-l2s analyse exo-type ?values)
+ "l2b" (analyse-jvm-l2b analyse exo-type ?values)
+ "c2b" (analyse-jvm-c2b analyse exo-type ?values)
+ "c2s" (analyse-jvm-c2s analyse exo-type ?values)
+ "c2i" (analyse-jvm-c2i analyse exo-type ?values)
+ "c2l" (analyse-jvm-c2l analyse exo-type ?values)
+ "b2l" (analyse-jvm-b2l analyse exo-type ?values)
+ "s2l" (analyse-jvm-s2l analyse exo-type ?values)
;; else
- (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))))
+ (->> (&/fail-with-loc (str "[Analyser Error] Unknown JVM procedure: " proc))
+ (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)]
+ (|do [[_module _line _column] &/cursor]
+ (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code
+ (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def]
+ (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods)))))
+
+ (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)]
+ (|do [[_module _line _column] &/cursor]
+ (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code
+ (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def]
+ (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods)))))
+
+ (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)]
+ (|do [[_module _line _column] &/cursor]
+ (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code
+ (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def]
+ (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods)))))
+
+ (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)]
+ (analyse-jvm-instanceof analyse exo-type _class ?values))
+
+ (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)]
+ (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
+
+ (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)]
+ (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
+
+ (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)]
+ (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
+
+ (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)]
+ (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
+
+ (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)]
+ (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values))
+
+ (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)]
+ (analyse-jvm-getstatic analyse exo-type _class _field ?values))
+
+ (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)]
+ (analyse-jvm-getfield analyse exo-type _class _field ?values))
+
+ (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)]
+ (analyse-jvm-putstatic analyse exo-type _class _field ?values))
+
+ (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)]
+ (analyse-jvm-putfield analyse exo-type _class _field ?values))))
+ ))
diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj
index 9859db068..27de43765 100644
--- a/luxc/src/lux/base.clj
+++ b/luxc/src/lux/base.clj
@@ -4,6 +4,11 @@
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array))
+(def !log! (atom false))
+(defn flag-prn! [& args]
+ (when @!log!
+ (apply prn args)))
+
;; [Tags]
(def unit-tag (.intern (str (char 0) "unit" (char 0))))
@@ -112,19 +117,11 @@
"locals"
"closure"])
-;; ModuleState
-(defvariant
- ("Active" 0)
- ("Compiled" 0)
- ("Cached" 0))
-
;; Host
(deftuple
["writer"
"loader"
"classes"
- "catching"
- "module-states"
"type-env"
"dummy-mappings"
])
@@ -137,10 +134,14 @@
("REPL" 0))
(deftuple
- ["compiler-name"
- "compiler-version"
+ ["compiler-version"
"compiler-mode"])
+;; Hosts
+(defvariant
+ ("Jvm" 1)
+ ("Js" 1))
+
(deftuple
["info"
"source"
@@ -151,6 +152,7 @@
"expected"
"seed"
"scope-type-vars"
+ "catching"
"host"])
;; Compiler
@@ -223,15 +225,10 @@
("DictA" 1))
;; [Exports]
-(def ^:const name-field "_name")
-(def ^:const hash-field "_hash")
(def ^:const value-field "_value")
-(def ^:const compiler-field "_compiler")
-(def ^:const eval-field "_eval")
(def ^:const module-class-name "_")
(def ^:const +name-separator+ ";")
-(def ^:const ^String compiler-name "Lux/JVM")
(def ^:const ^String compiler-version "0.6.0")
;; Constructors
@@ -312,7 +309,7 @@
nil
($Cons [k v] table*)
- (if (.equals ^Object k slot)
+ (if (= k slot)
v
(recur slot table*))))
@@ -322,7 +319,7 @@
($Cons (T [slot value]) $Nil)
($Cons [k v] table*)
- (if (.equals ^Object k slot)
+ (if (= k slot)
($Cons (T [slot value]) table*)
($Cons (T [k v]) (|put slot value table*)))
))
@@ -333,7 +330,7 @@
table
($Cons [k v] table*)
- (if (.equals ^Object k slot)
+ (if (= k slot)
table*
($Cons (T [k v]) (|remove slot table*)))))
@@ -343,7 +340,7 @@
table
($Cons [k* v] table*)
- (if (.equals ^Object k k*)
+ (if (= k k*)
($Cons (T [k* (f v)]) table*)
($Cons (T [k* v]) (|update k f table*)))))
@@ -469,7 +466,7 @@
false
($Cons [k* _] table*)
- (or (.equals ^Object k k*)
+ (or (= k k*)
(|contains? k table*))))
(defn |member? [x xs]
@@ -666,6 +663,18 @@
(return* state unit-tag)
(fail* msg)))))
+(defn |some [f xs]
+ "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))"
+ (|case xs
+ ($Nil)
+ $None
+
+ ($Cons x xs*)
+ (|case (f x)
+ ($None) (|some f xs*)
+ output output)
+ ))
+
(defn ^:private normalize-char [char]
(case char
\* "_ASTER_"
@@ -697,10 +706,6 @@
(defn normalize-name [ident]
(reduce str "" (map normalize-char ident)))
-(def classes
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $classes)))))
-
(def +init-bindings+
(T [;; "lux;counter"
0
@@ -718,62 +723,105 @@
+init-bindings+]
))
-(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
- (class (byte-array []))
- Integer/TYPE
- Integer/TYPE]))
- (.setAccessible true))]
- (defn memory-class-loader [store]
- (proxy [java.lang.ClassLoader]
- []
- (findClass [^String class-name]
- (if-let [^bytes bytecode (get @store class-name)]
- (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))]))
- (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))
-
-(def loader
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $loader)))))
-
-(defn host [_]
- (let [store (atom {})]
- (T [;; "lux;writer"
- $None
- ;; "lux;loader"
- (memory-class-loader store)
- ;; "lux;classes"
- store
- ;; "lux;catching"
- $Nil
- ;; "lux;module-states"
- (|table)
- ;; lux;type-env
- (|table)
- ;; lux;dummy-mappings
- (|table)
- ])))
+(do-template [<tag> <host> <ask> <change> <with>]
+ (do (def <host>
+ (fn [compiler]
+ (|case (get$ $host compiler)
+ (<tag> host-data)
+ (return* compiler host-data)
+
+ _
+ ((fail-with-loc "[Error] Wrong host.") compiler))))
+
+ (def <ask>
+ (fn [compiler]
+ (|case (get$ $host compiler)
+ (<tag> host-data)
+ (return* compiler true)
+
+ _
+ (return* compiler false))))
+
+ (defn <change> [slot updater]
+ (|do [host <host>]
+ (fn [compiler]
+ (return* (set$ $host (<tag> (update$ slot updater host)) compiler)
+ (get$ slot host)))))
+
+ (defn <with> [slot updater body]
+ (|do [old-val (<change> slot updater)
+ ?output-val body
+ new-val (<change> slot (fn [_] old-val))]
+ (return ?output-val))))
+
+ $Jvm jvm-host jvm? change-jvm-host-slot with-jvm-host-slot
+ $Js js-host js? change-js-host-slot with-js-host-slot
+ )
+
+(do-template [<name> <slot>]
+ (def <name>
+ (|do [host jvm-host]
+ (return (get$ <slot> host))))
+
+ loader $loader
+ classes $classes
+ get-type-env $type-env
+ )
+
+(def get-writer
+ (|do [host jvm-host]
+ (|case (get$ $writer host)
+ ($Some writer)
+ (return writer)
+
+ _
+ (fail-with-loc "[Error] Writer hasn't been set."))))
+
+(defn with-writer [writer body]
+ (with-jvm-host-slot $writer (fn [_] ($Some writer)) body))
+
+(defn with-type-env [type-env body]
+ "(All [a] (-> TypeEnv (Lux a) (Lux a)))"
+ (with-jvm-host-slot $type-env (partial |++ type-env) body))
+
+(defn push-dummy-name [real-name store-name]
+ (change-jvm-host-slot $dummy-mappings (partial $Cons (T [real-name store-name]))))
+
+(def pop-dummy-name
+ (change-jvm-host-slot $dummy-mappings |tail))
+
+(defn de-alias-class [class-name]
+ (|do [host jvm-host]
+ (return (|case (|some #(|let [[real-name store-name] %]
+ (if (= real-name class-name)
+ ($Some store-name)
+ $None))
+ (get$ $dummy-mappings host))
+ ($Some store-name)
+ store-name
+
+ _
+ class-name))))
(defn with-no-catches [body]
"(All [a] (-> (Lux a) (Lux a)))"
(fn [state]
- (let [old-catching (->> state (get$ $host) (get$ $catching))]
- (|case (body (update$ $host #(set$ $catching $Nil %) state))
+ (let [old-catching (->> state (get$ $catching))]
+ (|case (body (set$ $catching $Nil state))
($Right state* output)
- (return* (update$ $host #(set$ $catching old-catching %) state*) output)
+ (return* (set$ $catching old-catching state*) output)
($Left msg)
(fail* msg)))))
(defn default-compiler-info [mode]
- (T [;; compiler-name
- compiler-name
- ;; compiler-version
+ (T [;; compiler-version
compiler-version
;; compiler-mode
mode]
))
-(defn init-state [mode]
+(defn init-state [mode host-data]
(T [;; "lux;info"
(default-compiler-info mode)
;; "lux;source"
@@ -792,8 +840,10 @@
0
;; scope-type-vars
$Nil
+ ;; catching
+ $Nil
;; "lux;host"
- (host nil)]
+ host-data]
))
(defn save-module [body]
@@ -838,16 +888,6 @@
(fn [state]
(return* state (->> state (get$ $info) (get$ $compiler-mode)))))
-(def get-writer
- (fn [state]
- (let [writer* (->> state (get$ $host) (get$ $writer))]
- (|case writer*
- ($Some datum)
- (return* state datum)
-
- _
- ((fail-with-loc "[Error] Writer hasn't been set.") state)))))
-
(def get-top-local-env
(fn [state]
(try (let [top (|head (get$ $scopes state))]
@@ -971,18 +1011,6 @@
_
output)))))
-(defn with-writer [writer body]
- (fn [state]
- (let [old-writer (->> state (get$ $host) (get$ $writer))
- output (body (update$ $host #(set$ $writer ($Some writer) %) state))]
- (|case output
- ($Right ?state ?value)
- (return* (update$ $host #(set$ $writer old-writer %) ?state)
- ?value)
-
- _
- output))))
-
(defn with-expected-type [type body]
"(All [a] (-> Type (Lux a)))"
(fn [state]
@@ -1059,13 +1087,13 @@
(let [clean-separators (fn [^String input]
(.replaceAll input "_" ""))
deg-text-to-digits (fn [^String input]
- (loop [output (vec (repeat deg-bits 0))
- index (dec (.length input))]
- (if (>= index 0)
- (let [digit (Byte/parseByte (.substring input index (inc index)))]
- (recur (assoc output index digit)
- (dec index)))
- output)))
+ (loop [output (vec (repeat deg-bits 0))
+ index (dec (.length input))]
+ (if (>= index 0)
+ (let [digit (Byte/parseByte (.substring input index (inc index)))]
+ (recur (assoc output index digit)
+ (dec index)))
+ output)))
times5 (fn [index digits]
(loop [index index
carry 0
@@ -1077,58 +1105,58 @@
(assoc digits index (rem raw 10))))
digits)))
deg-digit-power (fn [level]
- (loop [output (-> (vec (repeat deg-bits 0))
- (assoc level 1))
- times level]
- (if (>= times 0)
- (recur (times5 level output)
- (dec times))
- output)))
+ (loop [output (-> (vec (repeat deg-bits 0))
+ (assoc level 1))
+ times level]
+ (if (>= times 0)
+ (recur (times5 level output)
+ (dec times))
+ output)))
deg-digits-lt (fn deg-digits-lt
- ([subject param index]
- (and (< index deg-bits)
- (or (< (get subject index)
- (get param index))
- (and (= (get subject index)
- (get param index))
- (deg-digits-lt subject param (inc index))))))
- ([subject param]
- (deg-digits-lt subject param 0)))
+ ([subject param index]
+ (and (< index deg-bits)
+ (or (< (get subject index)
+ (get param index))
+ (and (= (get subject index)
+ (get param index))
+ (deg-digits-lt subject param (inc index))))))
+ ([subject param]
+ (deg-digits-lt subject param 0)))
deg-digits-sub-once (fn [subject param-digit index]
- (if (>= (get subject index)
- param-digit)
- (update-in subject [index] #(- % param-digit))
- (recur (update-in subject [index] #(- 10 (- param-digit %)))
- 1
- (dec index))))
+ (if (>= (get subject index)
+ param-digit)
+ (update-in subject [index] #(- % param-digit))
+ (recur (update-in subject [index] #(- 10 (- param-digit %)))
+ 1
+ (dec index))))
deg-digits-sub (fn [subject param]
- (loop [target subject
- index (dec deg-bits)]
- (if (>= index 0)
- (recur (deg-digits-sub-once target (get param index) index)
- (dec index))
- target)))
+ (loop [target subject
+ index (dec deg-bits)]
+ (if (>= index 0)
+ (recur (deg-digits-sub-once target (get param index) index)
+ (dec index))
+ target)))
deg-digits-to-text (fn [digits]
- (loop [output ""
- index (dec deg-bits)]
- (if (>= index 0)
- (recur (-> (get digits index)
- (Character/forDigit 10)
- (str output))
- (dec index))
- output)))
+ (loop [output ""
+ index (dec deg-bits)]
+ (if (>= index 0)
+ (recur (-> (get digits index)
+ (Character/forDigit 10)
+ (str output))
+ (dec index))
+ output)))
add-deg-digit-powers (fn [dl dr]
- (loop [index (dec deg-bits)
- output (vec (repeat deg-bits 0))
- carry 0]
- (if (>= index 0)
- (let [raw (+ carry
- (get dl index)
- (get dr index))]
- (recur (dec index)
- (assoc output index (rem raw 10))
- (int (/ raw 10))))
- output)))]
+ (loop [index (dec deg-bits)
+ output (vec (repeat deg-bits 0))
+ carry 0]
+ (if (>= index 0)
+ (let [raw (+ carry
+ (get dl index)
+ (get dr index))]
+ (recur (dec index)
+ (assoc output index (rem raw 10))
+ (int (/ raw 10))))
+ output)))]
;; Based on the LuxRT.encode_deg method
(defn encode-deg [input]
(if (= 0 input)
@@ -1342,32 +1370,6 @@
($Some xs**) ($Some ($Cons x xs**)))
)))
-(do-template [<flagger> <asker> <tag>]
- (do (defn <flagger> [module]
- "(-> Text (Lux Unit))"
- (fn [state]
- (let [state* (update$ $host (fn [host]
- (update$ $module-states
- (fn [module-states]
- (|put module <tag> module-states))
- host))
- state)]
- ($Right (T [state* unit-tag])))))
- (defn <asker> [module]
- "(-> Text (Lux Bool))"
- (fn [state]
- (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))]
- ($Right (T [state (|case module-state
- (<tag>) true
- _ false)]))
- ($Right (T [state false])))
- )))
-
- flag-active-module active-module? $Active
- flag-compiled-module compiled-module? $Compiled
- flag-cached-module cached-module? $Cached
- )
-
(do-template [<name> <default> <op>]
(defn <name> [p xs]
"(All [a] (-> (-> a Bool) (List a) Bool))"
@@ -1397,40 +1399,6 @@
output
output)))
-(defn |some [f xs]
- "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))"
- (|case xs
- ($Nil)
- $None
-
- ($Cons x xs*)
- (|case (f x)
- ($None) (|some f xs*)
- output output)
- ))
-
-(def get-type-env
- "(Lux TypeEnv)"
- (fn [state]
- (return* state (->> state (get$ $host) (get$ $type-env)))))
-
-(defn with-type-env [type-env body]
- "(All [a] (-> TypeEnv (Lux a) (Lux a)))"
- (fn [state]
- (|let [state* (update$ $host #(update$ $type-env (partial |++ type-env) %)
- state)]
- (|case (body state*)
- ($Right [state** output])
- ($Right (T [(update$ $host
- #(set$ $type-env
- (->> state (get$ $host) (get$ $type-env))
- %)
- state**)
- output]))
-
- ($Left msg)
- ($Left msg)))))
-
(defn |take [n xs]
(|case (T [n xs])
[0 _] $Nil
@@ -1476,38 +1444,6 @@
($Left msg)
($Left msg))))
-(defn push-dummy-name [real-name store-name]
- (fn [state]
- ($Right (T [(update$ $host
- #(update$ $dummy-mappings
- (partial $Cons (T [real-name store-name]))
- %)
- state)
- nil]))))
-
-(def pop-dummy-name
- (fn [state]
- ($Right (T [(update$ $host
- #(update$ $dummy-mappings
- |tail
- %)
- state)
- nil]))))
-
-(defn de-alias-class [class-name]
- (fn [state]
- ($Right (T [state
- (|case (|some #(|let [[real-name store-name] %]
- (if (= real-name class-name)
- ($Some store-name)
- $None))
- (->> state (get$ $host) (get$ $dummy-mappings)))
- ($Some store-name)
- store-name
-
- _
- class-name)]))))
-
(defn |eitherL [left right]
(fn [compiler]
(|case (run-state left compiler)
diff --git a/luxc/src/lux/compiler.clj b/luxc/src/lux/compiler.clj
index 4792a1809..bffedb69e 100644
--- a/luxc/src/lux/compiler.clj
+++ b/luxc/src/lux/compiler.clj
@@ -1,267 +1,36 @@
(ns lux.compiler
(:refer-clojure :exclude [compile])
- (:require (clojure [string :as string]
- [set :as set]
- [template :refer [do-template]])
- clojure.core.match
+ (:require 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]
- [host :as &host])
- [lux.host.generics :as &host-generics]
- [lux.optimizer :as &o]
- [lux.analyser.base :as &a]
- [lux.analyser.module :as &a-module]
- (lux.compiler [base :as &&]
- [cache :as &&cache]
- [lux :as &&lux]
- [host :as &&host]
- [case :as &&case]
- [lambda :as &&lambda]
- [module :as &&module]
+ (lux [base :as & :refer [|let |do return* return |case]])
+ (lux.compiler [core :as &&core]
[io :as &&io]
- [parallel :as &&parallel])
- (lux.compiler.cache [type :as &&&type]
- [ann :as &&&ann]))
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor)))
+ [parallel :as &&parallel]
+ [jvm :as &&jvm]
+ [js :as &&js]
+ )))
-;; [Resources]
-(def ^:private !source->last-line (atom nil))
-
-(defn compile-expression [$begin syntax]
- (|let [[[?type [_file-name _line _]] ?form] syntax]
- (|do [^MethodVisitor *writer* &/get-writer
- :let [debug-label (new Label)
- _ (when (not= _line (get @!source->last-line _file-name))
- (doto *writer*
- (.visitLabel debug-label)
- (.visitLineNumber (int _line) debug-label))
- (swap! !source->last-line assoc _file-name _line))]]
- (|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/$real ?value)
- (&&lux/compile-real ?value)
-
- (&o/$char ?value)
- (&&lux/compile-char ?value)
-
- (&o/$text ?value)
- (&&lux/compile-text ?value)
-
- (&o/$tuple ?elems)
- (&&lux/compile-tuple (partial compile-expression $begin) ?elems)
-
- (&o/$var (&/$Local ?idx))
- (&&lux/compile-local (partial compile-expression $begin) ?idx)
-
- (&o/$captured ?scope ?captured-id ?source)
- (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source)
-
- (&o/$var (&/$Global ?owner-class ?name))
- (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name)
-
- (&o/$apply ?fn ?args)
- (&&lux/compile-apply (partial compile-expression $begin) ?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 (partial compile-expression $begin) $begin _register-offset ?args)
-
- (&o/$variant ?tag ?tail ?members)
- (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
-
- (&o/$case ?value [?pm ?bodies])
- (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies)
-
- (&o/$let _value _register _body)
- (&&lux/compile-let (partial compile-expression $begin) _value _register _body)
-
- (&o/$record-get _value _path)
- (&&lux/compile-record-get (partial compile-expression $begin) _value _path)
-
- (&o/$if _test _then _else)
- (&&lux/compile-if (partial compile-expression $begin) _test _then _else)
-
- (&o/$function _register-offset ?arity ?scope ?env ?body)
- (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
-
- (&o/$ann ?value-ex ?type-ex)
- (compile-expression $begin ?value-ex)
-
- (&o/$proc [?proc-category ?proc-name] ?args special-args)
- (&&host/compile-host (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)
-
- _
- (assert false (prn-str 'compile-expression (&/adt->text syntax)))
- ))
- ))
-
-(defn init!
- "(-> (List Text) Null)"
- [resources-dirs ^String target-dir]
- (do (reset! &&/!output-dir target-dir)
+(defn init! [platform resources-dirs ^String target-dir]
+ (do (reset! &&core/!output-dir target-dir)
(&&parallel/setup!)
(&&io/init-libs!)
- (reset! !source->last-line {})
(.mkdirs (new java.io.File target-dir))
- (let [class-loader (ClassLoader/getSystemClassLoader)
- addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL]))
- (.setAccessible true))]
- (doseq [^String resources-dir (&/->seq resources-dirs)]
- (.invoke addURL class-loader
- (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)]))))))
-
-(defn eval! [expr]
- (&/with-eval
- (|do [module &/get-module-name
- id &/gen-id
- [file-name _ _] &/cursor
- :let [class-name (str (&host/->module-class module) "/" id)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- class-name nil "java/lang/Object" nil)
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil)
- (doto (.visitEnd)))
- (.visitSource file-name nil))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor *writer* &/get-writer
- :let [_ (.visitCode *writer*)]
- _ (compile-expression nil expr)
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [bytecode (.toByteArray (doto =class
- .visitEnd))]
- _ (&&/save-class! (str id) bytecode)
- loader &/loader]
- (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id))
- (.getField &/eval-field)
- (.get nil)
- return))))
+ (case platform
+ "jvm" (&&jvm/init! resources-dirs target-dir)
+ "js" (&&js/init! resources-dirs target-dir))
+ ))
(def all-compilers
- (let [compile-expression* (partial compile-expression nil)]
- (&/T [(partial &&lux/compile-def compile-expression)
- (partial &&lux/compile-program compile-expression*)
- (partial &&host/compile-jvm-class compile-expression*)
- &&host/compile-jvm-interface])))
+ &&jvm/all-compilers)
-(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)
- +datum-sig+ "Ljava/lang/Object;"]
- (defn compile-module [source-dirs name]
- (let [file-name (str name ".lux")]
- (|do [file-content (&&io/read-file source-dirs file-name)
- :let [file-hash (hash file-content)
- compile-module!! (&&parallel/parallel-compilation (partial compile-module source-dirs))]]
- (&/|eitherL (&&cache/load name)
- (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 "[Compiler Error] Can't redefine a module!")
- (|do [_ (&&cache/delete name)
- _ (&a-module/create-module name file-hash)
- _ (&/flag-active-module name)
- :let [module-class-name (str (&host/->module-class name) "/_")
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- module-class-name nil "java/lang/Object" nil)
- (-> (.visitField +field-flags+ &/hash-field "I" nil file-hash)
- .visitEnd)
- (-> (.visitField +field-flags+ &/compiler-field "Ljava/lang/String;" nil &/compiler-version)
- .visitEnd)
- (.visitSource file-name nil))]
- _ (if (= "lux" name)
- (|do [_ &&host/compile-Function-class
- _ &&host/compile-LuxRT-class]
- (return nil))
- (return nil))]
- (fn [state]
- (|case ((&/with-writer =class
- (&/exhaust% compiler-step))
- (&/set$ &/$source (&reader/from name file-content) state))
- (&/$Right ?state _)
- (&/run-state (|do [:let [_ (.visitEnd =class)]
- module-anns (&a-module/get-anns name)
- defs &a-module/defs
- imports &a-module/imports
- tag-groups &&module/tag-groups
- :let [def-entries (->> defs
- (&/|map (fn [_def]
- (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def]
- (if (= "" ?alias)
- (str ?name &&/datum-separator (&&&type/serialize-type ?def-type) &&/datum-separator (&&&ann/serialize-anns ?def-anns))
- (str ?name &&/datum-separator ?alias)))))
- (&/|interpose &&/entry-separator)
- (&/fold str ""))
- import-entries (->> imports
- (&/|map (fn [import]
- (|let [[_module _hash] import]
- (str _module &&/datum-separator _hash))))
- (&/|interpose &&/entry-separator)
- (&/fold str ""))
- tag-entries (->> tag-groups
- (&/|map (fn [group]
- (|let [[type tags] group]
- (->> tags
- (&/|interpose &&/datum-separator)
- (&/fold str "")
- (str type &&/datum-separator)))))
- (&/|interpose &&/entry-separator)
- (&/fold str ""))
- module-descriptor (->> (&/|list import-entries
- tag-entries
- (&&&ann/serialize-anns module-anns)
- def-entries)
- (&/|interpose &&/section-separator)
- (&/fold str ""))]
- _ (&/flag-compiled-module name)
- _ (&&/save-class! &/module-class-name (.toByteArray =class))
- _ (&&/write-module-descriptor! name module-descriptor)]
- (return file-hash))
- ?state)
-
- (&/$Left ?message)
- (&/fail* ?message))))))))
- )
- )))
+(defn eval! [expr]
+ (&&jvm/eval! expr))
-(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 [_ (&&cache/pre-load-cache! source-dirs)
- _ (compile-module source-dirs "lux")]
- (compile-module source-dirs program-module))]
- (|case (m-action (&/init-state mode))
- (&/$Right ?state _)
- (do (println "Compilation complete!")
- (&&cache/clean ?state))
+(defn compile-module [source-dirs name]
+ (&&jvm/compile-module source-dirs name))
- (&/$Left ?message)
- (binding [*out* !err!]
- (do (println (str "Compilation failed:\n" ?message))
- (flush)
- (System/exit 1))))))))
+(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)))
diff --git a/luxc/src/lux/compiler/cache.clj b/luxc/src/lux/compiler/cache.clj
index 8ca319d66..c51691322 100644
--- a/luxc/src/lux/compiler/cache.clj
+++ b/luxc/src/lux/compiler/cache.clj
@@ -7,55 +7,35 @@
(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 [base :as &&]
+ (lux.compiler [core :as &&core]
[io :as &&io])
(lux.compiler.cache [type :as &&&type]
[ann :as &&&ann]))
- (:import (java.io File
- BufferedOutputStream
- FileOutputStream)
- (java.lang.reflect Field)))
+ (: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)))
-
-(defn ^:private clean-file [^File file]
- "(-> File (,))"
+;; [Resources]
+(defn ^:private delete-all-module-files [^File file]
(doseq [^File f (seq (.listFiles file))
:when (not (.isDirectory f))]
(.delete f)))
-(defn ^:private get-field [^String field-name ^Class class]
- "(-> Text Class Object)"
- (-> class ^Field (.getField field-name) (.get nil)))
-
-;; [Resources]
-(def module-class-file (str &/module-class-name ".class"))
+(defn ^:private ^String module-path [module]
+ (str @&&core/!output-dir
+ java.io.File/separator
+ (.replace ^String (&host/->module-class module) "/" java.io.File/separator)))
(defn cached? [module]
"(-> Text Bool)"
- (.exists (new File (str @&&/!output-dir
- java.io.File/separator
- (.replace ^String (&host/->module-class module) "/" java.io.File/separator)
- java.io.File/separator
- module-class-file))))
+ (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name))))
(defn delete [module]
"(-> Text (Lux Null))"
(fn [state]
- (do (clean-file (new File (str @&&/!output-dir
- java.io.File/separator
- (.replace ^String (&host/->module-class module) "/" java.io.File/separator))))
+ (do (delete-all-module-files (new File (module-path module)))
(return* state nil))))
(defn ^:private module-dirs
@@ -71,9 +51,9 @@
(defn clean [state]
"(-> Compiler Null)"
(let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set)
- output-dir-prefix (str (.getAbsolutePath (new File ^String @&&/!output-dir)) java.io.File/separator)
+ output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator)
outdated? #(->> % (contains? needed-modules) not)
- outdated-modules (->> (new File ^String @&&/!output-dir)
+ outdated-modules (->> (new File ^String @&&core/!output-dir)
.listFiles (filter #(.isDirectory ^File %))
(map module-dirs) doall (apply concat)
(map (fn [^File dir-file]
@@ -84,39 +64,17 @@
corrected-dir-module)))
(filter outdated?))]
(doseq [^String f outdated-modules]
- (clean-file (new File (str output-dir-prefix f))))
+ (delete-all-module-files (new File (str output-dir-prefix f))))
nil))
-(defn ^:private install-all-classes-in-module [!classes module* ^String module-path]
- (let [classes+bytecode (for [^File file (seq (.listFiles (File. module-path)))
- :when (not (.isDirectory file))
- :let [file-name (.getName file)]
- :when (not= module-class-file file-name)]
- [(second (re-find #"^(.*)\.class$" file-name))
- (read-file file)])
- _ (doseq [[class-name bytecode] classes+bytecode]
- (swap! !classes assoc (str module* "." class-name) bytecode))]
- (map first classes+bytecode)))
-
-(defn ^:private assume-async-result
- "(-> (Error Compiler) (Lux Null))"
- [result]
- (fn [_]
- (|case result
- (&/$Left error)
- (&/$Left error)
-
- (&/$Right compiler)
- (return* compiler nil))))
-
(defn ^:private parse-tag-groups [^String tags-section]
(if (= "" tags-section)
&/$Nil
(-> tags-section
- (.split &&/entry-separator)
+ (.split &&core/entry-separator)
seq
(->> (map (fn [^String _group]
- (let [[_type & _tags] (.split _group &&/datum-separator)]
+ (let [[_type & _tags] (.split _group &&core/datum-separator)]
(&/T [_type (->> _tags seq &/->list)])))))
&/->list)))
@@ -125,48 +83,49 @@
(|do [[was-exported? =type] (&a-module/type-def module _type)]
(&a-module/declare-tags module _tags was-exported? =type))))
-(defn ^:private process-def-entry [loader module ^String _def-entry]
- (let [parts (.split _def-entry &&/datum-separator)]
+(defn ^:private process-def-entry [load-def-value module ^String _def-entry]
+ (let [parts (.split _def-entry &&core/datum-separator)]
(case (alength parts)
2 (let [[_name _alias] parts
[_ __module __name] (re-find #"^(.*);(.*)$" _alias)
- def-class (&&/load-class! loader (str (&host-generics/->class-name __module) "." (&host/def-name __name)))
- def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentA (&/T [__module __name]))]))
- def-value (get-field &/value-field def-class)]
- (|do [def-type (&a-module/def-type __module __name)]
+ def-anns (&/|list (&/T [&a-meta/alias-tag (&/$IdentA (&/T [__module __name]))]))]
+ (|do [def-type (&a-module/def-type __module __name)
+ def-value (load-def-value __module __name)]
(&a-module/define module _name def-type def-anns def-value)))
3 (let [[_name _type _anns] parts
- def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name _name)))
def-anns (&&&ann/deserialize-anns _anns)
- [def-type _] (&&&type/deserialize-type _type)
- def-value (get-field &/value-field def-class)]
- (&a-module/define module _name def-type def-anns def-value)))))
+ [def-type _] (&&&type/deserialize-type _type)]
+ (|do [def-value (load-def-value module _name)]
+ (&a-module/define module _name def-type def-anns def-value))))))
(defn ^:private uninstall-cache [module]
(|do [_ (delete module)]
(return false)))
-(defn ^:private install-module [loader module module-hash imports tag-groups module-anns def-entries]
+(defn ^:private install-module [load-def-value module module-hash imports tag-groups module-anns def-entries]
(|do [_ (&a-module/create-module module module-hash)
+ _ (&a-module/flag-cached-module module)
_ (&a-module/set-anns module-anns module)
_ (&a-module/set-imports imports)
- _ (&/map% (partial process-def-entry loader module)
+ _ (&/map% (partial process-def-entry load-def-value module)
def-entries)
_ (&/map% (partial process-tag-group module) tag-groups)]
(return nil)))
-(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash loader]
- (|do [^String descriptor (&&/read-module-descriptor! module-name)
- :let [[imports-section tags-section module-anns-section defs-section] (.split descriptor &&/section-separator)
- imports (let [imports (vec (.split ^String imports-section &&/entry-separator))
+(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash
+ _imports-section _tags-section _module-anns-section _defs-section
+ load-def-value install-all-defs-in-module uninstall-all-defs-in-module]
+ (|do [^String descriptor (&&core/read-module-descriptor! module-name)
+ :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator))
imports (if (= [""] imports)
&/$Nil
(&/->list imports))]
- (&/|map #(.split ^String % &&/datum-separator 2) imports))]
+ (&/|map #(.split ^String % &&core/datum-separator 2) imports))]
cache-table* (&/fold% (fn [cache-table* _import]
(|do [:let [[_module _hash] _import]
- file-content (&&io/read-file source-dirs (str _module ".lux"))
- output (pre-load! source-dirs cache-table* _module (hash file-content))]
+ [file-name file-content] (&&io/read-file source-dirs _module)
+ output (pre-load! source-dirs cache-table* _module (hash file-content)
+ load-def-value install-all-defs-in-module uninstall-all-defs-in-module)]
(return output)))
cache-table
imports)]
@@ -174,13 +133,14 @@
(|let [[_module _hash] _import]
(contains? cache-table* _module)))
imports)
- (let [tag-groups (parse-tag-groups tags-section)
- module-anns (&&&ann/deserialize-anns module-anns-section)
- def-entries (let [def-entries (vec (.split ^String defs-section &&/entry-separator))]
+ (let [tag-groups (parse-tag-groups _tags-section)
+ module-anns (&&&ann/deserialize-anns _module-anns-section)
+ def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))]
(if (= [""] def-entries)
&/$Nil
(&/->list def-entries)))]
- (|do [_ (install-module loader module-name module-hash
+ (|do [_ (install-all-defs-in-module module-name)
+ _ (install-module load-def-value module-name module-hash
imports tag-groups module-anns def-entries)
=module (&/find-module module-name)]
(return (&/T [true (assoc cache-table* module-name =module)]))))
@@ -191,14 +151,14 @@
(let [children (for [^File child (seq (.listFiles parent))
entry (enumerate-cached-modules!* child)]
entry)]
- (if (.exists (new File parent "_.class"))
+ (if (.exists (new File parent &&core/lux-module-descriptor-name))
(list* (.getAbsolutePath parent)
children)
children))
(list)))
(defn ^:private enumerate-cached-modules! []
- (let [output-dir (new File ^String @&&/!output-dir)
+ (let [output-dir (new File ^String @&&core/!output-dir)
prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))]
(->> output-dir
enumerate-cached-modules!*
@@ -208,48 +168,45 @@
(.substring prefix-to-subtract)))
&/->list)))
-(defn ^:private pre-load! [source-dirs cache-table module module-hash]
- (cond (contains? cache-table module)
+(defn ^:private pre-load! [source-dirs cache-table module-name module-hash
+ load-def-value install-all-defs-in-module uninstall-all-defs-in-module]
+ (cond (contains? cache-table module-name)
(return cache-table)
- (not (cached? module))
+ (not (cached? module-name))
(return cache-table)
:else
- (|do [loader &/loader
- !classes &/classes
- :let [module* (&host-generics/->class-name module)
- module-path (str @&&/!output-dir java.io.File/separator module)
- class-name (str module* "." &/module-class-name)
- ^Class module-class (do (swap! !classes assoc class-name (read-file (new File (str module-path java.io.File/separator module-class-file))))
- (&&/load-class! loader class-name))
- installed-classes (install-all-classes-in-module !classes module* module-path)
- valid-cache? (and (= module-hash (get-field &/hash-field module-class))
- (= &/compiler-version (get-field &/compiler-field module-class)))
- drop-cache! (|do [_ (uninstall-cache module)
- :let [_ (swap! !classes (fn [_classes-dict]
- (reduce dissoc _classes-dict installed-classes)))]]
+ (|do [^String descriptor (&&core/read-module-descriptor! module-name)
+ :let [[_compiler _hash _imports-section _tags-section _module-anns-section _defs-section] (.split descriptor &&core/section-separator)
+ drop-cache! (|do [_ (uninstall-cache module-name)
+ _ (uninstall-all-defs-in-module module-name)]
(return cache-table))]]
- (if valid-cache?
- (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module module-hash loader)
+ (if (and (= module-hash (Long/parseUnsignedLong ^String _hash))
+ (= &/compiler-version _compiler))
+ (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash
+ _imports-section _tags-section _module-anns-section _defs-section
+ load-def-value install-all-defs-in-module uninstall-all-defs-in-module)
_ (if success?
(return nil)
drop-cache!)]
(return cache-table*))
drop-cache!))))
-(def !pre-loaded-cache (atom nil))
-(defn pre-load-cache! [source-dirs]
+(def ^:private !pre-loaded-cache (atom nil))
+(defn pre-load-cache! [source-dirs
+ load-def-value install-all-defs-in-module uninstall-all-defs-in-module]
(|do [:let [fs-cached-modules (enumerate-cached-modules!)]
pre-loaded-modules (&/fold% (fn [cache-table module-name]
(fn [_compiler]
- (|case ((&&io/read-file source-dirs (str module-name ".lux"))
+ (|case ((&&io/read-file source-dirs module-name)
_compiler)
(&/$Left error)
(return* _compiler cache-table)
- (&/$Right _compiler* file-content)
- ((pre-load! source-dirs cache-table module-name (hash file-content))
+ (&/$Right _compiler* [file-name file-content])
+ ((pre-load! source-dirs cache-table module-name (hash file-content)
+ load-def-value install-all-defs-in-module uninstall-all-defs-in-module)
_compiler*))))
{}
fs-cached-modules)
@@ -268,7 +225,6 @@
(defn load [module-name]
"(-> Text (Lux Null))"
(if-let [module-struct (get @!pre-loaded-cache module-name)]
- (|do [_ (inject-module module-name module-struct)
- _ (&/flag-cached-module module-name)]
+ (|do [_ (inject-module module-name module-struct)]
(return nil))
(&/fail (str "[Cache Error] Module is not cached: " module-name))))
diff --git a/luxc/src/lux/compiler/core.clj b/luxc/src/lux/compiler/core.clj
new file mode 100644
index 000000000..15f03ea6e
--- /dev/null
+++ b/luxc/src/lux/compiler/core.clj
@@ -0,0 +1,82 @@
+(ns lux.compiler.core
+ (:require (clojure [template :refer [do-template]]
+ [string :as string])
+ [clojure.java.io :as io]
+ [clojure.core.match :as M :refer [matchv]]
+ clojure.core.match.array
+ (lux [base :as & :refer [|let |do return* return fail*]])
+ (lux.analyser [base :as &a]
+ [module :as &a-module])
+ (lux.compiler.cache [type :as &&&type]
+ [ann :as &&&ann]))
+ (:import (java.io File
+ BufferedOutputStream
+ FileOutputStream)))
+
+;; [Constants]
+(def !output-dir (atom nil))
+
+(def ^:const section-separator (->> 29 char str))
+(def ^:const datum-separator (->> 31 char str))
+(def ^:const entry-separator (->> 30 char str))
+
+;; [Utils]
+(defn write-file [^String file-name ^bytes data]
+ (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name))
+ (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))]
+ (.write stream data)
+ (.flush stream))))
+
+;; [Exports]
+(def ^String lux-module-descriptor-name "lux_module_descriptor")
+
+(defn write-module-descriptor! [^String name ^String descriptor]
+ (|do [_ (return nil)
+ :let [lmd-dir (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator))
+ _ (.mkdirs (File. lmd-dir))
+ _ (write-file (str lmd-dir java.io.File/separator lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]]
+ (return nil)))
+
+(defn read-module-descriptor! [^String name]
+ (|do [_ (return nil)]
+ (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name)
+ :encoding "UTF-8"))))
+
+(defn generate-module-descriptor [file-hash]
+ (|do [module-name &/get-module-name
+ module-anns (&a-module/get-anns module-name)
+ defs &a-module/defs
+ imports &a-module/imports
+ tag-groups &a-module/tag-groups
+ :let [def-entries (->> defs
+ (&/|map (fn [_def]
+ (|let [[?name ?alias [?def-type ?def-anns ?def-value]] _def]
+ (if (= "" ?alias)
+ (str ?name datum-separator (&&&type/serialize-type ?def-type) datum-separator (&&&ann/serialize-anns ?def-anns))
+ (str ?name datum-separator ?alias)))))
+ (&/|interpose entry-separator)
+ (&/fold str ""))
+ import-entries (->> imports
+ (&/|map (fn [import]
+ (|let [[_module _hash] import]
+ (str _module datum-separator _hash))))
+ (&/|interpose entry-separator)
+ (&/fold str ""))
+ tag-entries (->> tag-groups
+ (&/|map (fn [group]
+ (|let [[type tags] group]
+ (->> tags
+ (&/|interpose datum-separator)
+ (&/fold str "")
+ (str type datum-separator)))))
+ (&/|interpose entry-separator)
+ (&/fold str ""))
+ module-descriptor (->> (&/|list &/compiler-version
+ (Long/toUnsignedString file-hash)
+ import-entries
+ tag-entries
+ (&&&ann/serialize-anns module-anns)
+ def-entries)
+ (&/|interpose section-separator)
+ (&/fold str ""))]]
+ (return module-descriptor)))
diff --git a/luxc/src/lux/compiler/host.clj b/luxc/src/lux/compiler/host.clj
deleted file mode 100644
index f0249f3d3..000000000
--- a/luxc/src/lux/compiler/host.clj
+++ /dev/null
@@ -1,2762 +0,0 @@
-(ns lux.compiler.host
- (: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.type.host :as &host-type]
- [lux.host.generics :as &host-generics]
- [lux.analyser.base :as &a]
- [lux.compiler.base :as &&])
- (:import (org.objectweb.asm Opcodes
- Label
- ClassWriter
- MethodVisitor
- AnnotationVisitor)))
-
-;; [Utils]
-(def init-method "<init>")
-
-(let [class+method+sig {"boolean" &&/unwrap-boolean
- "byte" &&/unwrap-byte
- "short" &&/unwrap-short
- "int" &&/unwrap-int
- "long" &&/unwrap-long
- "float" &&/unwrap-float
- "double" &&/unwrap-double
- "char" &&/unwrap-char}]
- (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name]
- (if-let [unwrap (get class+method+sig class-name)]
- (doto *writer*
- unwrap)
- (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name)))))
-
-(let [boolean-class "java.lang.Boolean"
- byte-class "java.lang.Byte"
- short-class "java.lang.Short"
- int-class "java.lang.Integer"
- long-class "java.lang.Long"
- float-class "java.lang.Float"
- double-class "java.lang.Double"
- char-class "java.lang.Character"]
- (defn prepare-return! [^MethodVisitor *writer* *type*]
- (|case *type*
- (&/$UnitT)
- (.visitLdcInsn *writer* &/unit-tag)
-
- (&/$HostT "boolean" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class)))
-
- (&/$HostT "byte" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class)))
-
- (&/$HostT "short" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class)))
-
- (&/$HostT "int" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class)))
-
- (&/$HostT "long" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class)))
-
- (&/$HostT "float" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class)))
-
- (&/$HostT "double" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class)))
-
- (&/$HostT "char" (&/$Nil))
- (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class)))
-
- (&/$HostT _ _)
- nil
-
- (&/$NamedT ?name ?type)
- (prepare-return! *writer* ?type)
-
- (&/$ExT _)
- nil
-
- _
- (assert false (str 'prepare-return! " " (&type/show-type *type*))))
- *writer*))
-
-;; [Resources]
-(defn ^:private compile-annotation [writer ann]
- (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true)
- (-> (.visit param-name param-value)
- (->> (|let [[param-name param-value] param])
- (doseq [param (&/->seq (:params ann))])))
- (.visitEnd))
- nil)
-
-(defn ^:private compile-field [^ClassWriter writer field]
- (|case field
- (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
- (|let [=field (.visitField writer
- (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL)
- ?name
- (&host-generics/gclass->simple-signature ?gclass)
- (&host-generics/gclass->signature ?gclass) nil)]
- (do (&/|map (partial compile-annotation =field) ?anns)
- (.visitEnd =field)
- nil))
-
- (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type)
- (|let [=field (.visitField writer
- (+ (&host/privacy-modifier->flag =privacy-modifier)
- (&host/state-modifier->flag =state-modifier))
- =name
- (&host-generics/gclass->simple-signature =type)
- (&host-generics/gclass->signature =type) nil)]
- (do (&/|map (partial compile-annotation =field) =anns)
- (.visitEnd =field)
- nil))
- ))
-
-(defn ^:private compile-method-return [^MethodVisitor writer output]
- (|case output
- (&/$GenericClass "void" (&/$Nil))
- (.visitInsn writer Opcodes/RETURN)
-
- (&/$GenericClass "boolean" (&/$Nil))
- (doto writer
- &&/unwrap-boolean
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "byte" (&/$Nil))
- (doto writer
- &&/unwrap-byte
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "short" (&/$Nil))
- (doto writer
- &&/unwrap-short
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "int" (&/$Nil))
- (doto writer
- &&/unwrap-int
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass "long" (&/$Nil))
- (doto writer
- &&/unwrap-long
- (.visitInsn Opcodes/LRETURN))
-
- (&/$GenericClass "float" (&/$Nil))
- (doto writer
- &&/unwrap-float
- (.visitInsn Opcodes/FRETURN))
-
- (&/$GenericClass "double" (&/$Nil))
- (doto writer
- &&/unwrap-double
- (.visitInsn Opcodes/DRETURN))
-
- (&/$GenericClass "char" (&/$Nil))
- (doto writer
- &&/unwrap-char
- (.visitInsn Opcodes/IRETURN))
-
- (&/$GenericClass _class-name (&/$Nil))
- (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name))
- (.visitInsn Opcodes/ARETURN))
-
- _
- (.visitInsn writer Opcodes/ARETURN)))
-
-(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor]
- "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))"
- (|case input
- [_ (&/$GenericClass name params)]
- (case name
- "boolean" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-boolean
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))])))
- "byte" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-byte
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))])))
- "short" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-short
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))])))
- "int" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-int
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))])))
- "long" (do (doto method-visitor
- (.visitVarInsn Opcodes/LLOAD idx)
- &&/wrap-long
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)])))
- "float" (do (doto method-visitor
- (.visitVarInsn Opcodes/FLOAD idx)
- &&/wrap-float
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))])))
- "double" (do (doto method-visitor
- (.visitVarInsn Opcodes/DLOAD idx)
- &&/wrap-double
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)])))
- "char" (do (doto method-visitor
- (.visitVarInsn Opcodes/ILOAD idx)
- &&/wrap-char
- (.visitVarInsn Opcodes/ASTORE idx))
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))])))
- ;; else
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))])))
-
- [_ gclass]
- (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))]))
- ))
-
-(defn ^:private prepare-method-inputs [idx inputs method-visitor]
- "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))"
- (|case inputs
- (&/$Nil)
- (return &/$Nil)
-
- (&/$Cons input inputs*)
- (|do [[_ outputs*] (&/fold% (fn [idx+outputs input]
- (|do [:let [[_idx _outputs] idx+outputs]
- [idx* output] (prepare-method-input _idx input method-visitor)]
- (return (&/T [idx* (&/$Cons output _outputs)]))))
- (&/T [idx &/$Nil])
- inputs)]
- (return (&/list-join (&/|reverse outputs*))))
- ))
-
-(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def]
- (|case method-def
- (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
- (|let [?output (&/$GenericClass "void" (&/|list))
- =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ (&host/privacy-modifier->flag ?privacy-modifier)
- (if ?strict Opcodes/ACC_STRICT 0))
- init-method
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [[super-class-name super-class-params] ?super-class
- init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str ""))
- init-sig (str "(" init-types ")" "V")
- _ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 1 ?inputs =method)
- :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)]
- _ (->> ?ctor-args (&/|map &/|second) (&/map% compile))
- :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)]
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ (&host/privacy-modifier->flag ?privacy-modifier)
- (if =final? Opcodes/ACC_FINAL 0)
- (if ?strict Opcodes/ACC_STRICT 0))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 1 ?inputs =method)
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ Opcodes/ACC_PUBLIC
- (if ?strict Opcodes/ACC_STRICT 0))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 1 ?inputs =method)
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ (&host/privacy-modifier->flag ?privacy-modifier)
- (if ?strict Opcodes/ACC_STRICT 0)
- Opcodes/ACC_STATIC)
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitCode =method)]
- =input-tags (prepare-method-inputs 0 ?inputs =method)
- _ (compile (&o/optimize ?body))
- :let [_ (doto =method
- (compile-method-return ?output)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil))))
-
- (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ Opcodes/ACC_ABSTRACT
- (&host/privacy-modifier->flag ?privacy-modifier))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitEnd =method)]]
- (return nil))))
-
- (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
- (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
- (&/with-writer (.visitMethod class-writer
- (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE
- (&host/privacy-modifier->flag ?privacy-modifier))
- ?name
- simple-signature
- generic-signature
- (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (&/|map (partial compile-annotation =method) ?anns)
- _ (.visitEnd =method)]]
- (return nil))))
- ))
-
-(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl]
- (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl
- [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)
- =method (.visitMethod class-writer
- (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
- =name
- simple-signature
- generic-signature
- (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
- _ (&/|map (partial compile-annotation =method) =anns)
- _ (.visitEnd =method)]
- nil))
-
-(defn ^:private prepare-ctor-arg [^MethodVisitor writer type]
- (case type
- "boolean" (doto writer
- &&/unwrap-boolean)
- "byte" (doto writer
- &&/unwrap-byte)
- "short" (doto writer
- &&/unwrap-short)
- "int" (doto writer
- &&/unwrap-int)
- "long" (doto writer
- &&/unwrap-long)
- "float" (doto writer
- &&/unwrap-float)
- "double" (doto writer
- &&/unwrap-double)
- "char" (doto writer
- &&/unwrap-char)
- ;; else
- (doto writer
- (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type)))))
-
-(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object")
- <init>-return "V"]
- (defn ^:private anon-class-<init>-signature [env]
- (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
- <init>-return))
-
- (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args]
- (|let [[super-class-name super-class-params] super-class
- init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
- (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil)
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (doto =method
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0))]
- _ (&/map% (fn [type+term]
- (|let [[type term] type+term]
- (|do [_ (compile term)
- :let [_ (prepare-ctor-arg =method type)]]
- (return nil))))
- ctor-args)
- :let [_ (doto =method
- (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" <init>-return))
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
- (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (|case ?name+?captured
- [?name [_ (&o/$captured _ ?captured-id ?source)]])
- (doseq [?name+?captured (&/->seq env)])))
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))))
- )
-
-(defn ^:private constant-inits [fields]
- "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))"
- (&/fold &/|++
- &/$Nil
- (&/|map (fn [field]
- (|case field
- (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
- (&/|list (&/T [?name ?gclass ?value]))
-
- (&/$VariableFieldSyntax _)
- (&/|list)
- ))
- fields)))
-
-(declare compile-jvm-putstatic)
-(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args]
- (|do [module &/get-module-name
- [file-name line column] &/cursor
- :let [[?name ?params] class-decl
- class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces))
- full-name (str module "/" ?name)
- super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class))
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
- (&host/inheritance-modifier->flag ?inheritance-modifier))
- full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
- (.visitSource file-name nil))
- _ (&/|map (partial compile-annotation =class) ?anns)
- _ (&/|map (partial compile-field =class)
- ?fields)]
- _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods)
- _ (|case ??ctor-args
- (&/$Some ctor-args)
- (add-anon-class-<init> =class compile full-name ?super-class env ctor-args)
-
- _
- (return nil))
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor =method &/get-writer
- :let [_ (doto =method
- (.visitCode))]
- _ (&/map% (fn [ftriple]
- (|let [[fname fgclass fvalue] ftriple]
- (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass))))
- (constant-inits ?fields))
- :let [_ (doto =method
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))]
- (&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
-
-(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods]
- (|do [:let [[interface-name interface-vars] interface-decl]
- module &/get-module-name
- [file-name _ _] &/cursor
- :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers)
- =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE)
- (str module "/" interface-name)
- (if (= "" interface-signature) nil interface-signature)
- "java/lang/Object"
- (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
- (.visitSource file-name nil))
- _ (&/|map (partial compile-annotation =interface) ?anns)
- _ (do (&/|map (partial compile-method-decl =interface) ?methods)
- (.visitEnd =interface))]]
- (&&/save-class! interface-name (.toByteArray =interface))))
-
-(def compile-Function-class
- (|do [_ (return nil)
- :let [super-class "java/lang/Object"
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
- Opcodes/ACC_ABSTRACT
- ;; Opcodes/ACC_INTERFACE
- )
- &&/function-class nil super-class (into-array String []))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil)
- (doto (.visitEnd))))
- =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (dotimes [arity* &&/num-apply-variants]
- (let [arity (inc arity*)]
- (if (= 1 arity)
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil)
- (.visitEnd))
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil)
- (.visitCode)
- (-> (.visitVarInsn Opcodes/ALOAD idx)
- (->> (dotimes [idx arity])))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity)))
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitVarInsn Opcodes/ALOAD arity)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))))]]
- (&&/save-class! (second (string/split &&/function-class #"/"))
- (.toByteArray (doto =class .visitEnd)))))
-
-(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class]
- (|let [_ (let [$begin (new Label)
- $not-rec (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLabel $begin)
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
- (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
- (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
- (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size
- (.visitInsn Opcodes/ISUB) ;; sub-index
- (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple
- (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size
- (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem
- (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem
- (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index
- (.visitVarInsn Opcodes/ISTORE 1) ;;
- (.visitJumpInsn Opcodes/GOTO $begin)
- (.visitLabel $not-rec) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/POP2) ;;
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
- (.visitInsn Opcodes/AALOAD) ;; elem
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$begin (new Label)
- $is-last (new Label)
- $must-copy (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLabel $begin)
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
- (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
- (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
- (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem
- (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;;
- ;; Must recurse
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitInsn Opcodes/DUP) ;; tuple, tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size
- (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem
- (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem
- (.visitInsn Opcodes/AALOAD) ;; tuple-tail
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple
- (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size
- (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1
- (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size*
- (.visitInsn Opcodes/ISUB) ;; tuple-tail, index*
- (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail
- (.visitVarInsn Opcodes/ASTORE 0) ;;
- (.visitJumpInsn Opcodes/GOTO $begin)
- (.visitLabel $must-copy)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARRAYLENGTH)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $is-last) ;; tuple-size, index-last-elem
- (.visitInsn Opcodes/POP2) ;;
- (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
- (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
- (.visitInsn Opcodes/AALOAD) ;; elem
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$begin (new Label)
- $just-return (new Label)
- $then (new Label)
- $further (new Label)
- $not-right (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLabel $begin)
- (.visitVarInsn Opcodes/ILOAD 1) ;; tag
- (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum
- (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx
- (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag'
- &&/unwrap-int ;; tag, sum-tag
- (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag
- (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
- (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag
- (.visitInsn Opcodes/POP2)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $then) ;; tag, sum-tag
- (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last?
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last?
- (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return)
- (.visitJumpInsn Opcodes/GOTO $further)
- (.visitLabel $just-return)
- (.visitInsn Opcodes/POP2)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 2))
- (.visitInsn Opcodes/AALOAD)
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $further) ;; tag, sum-tag
- (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum
- (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index?
- (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last?
- (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag
- (.visitInsn Opcodes/ISUB) ;; sub-tag
- (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum
- (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx
- (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag
- (.visitVarInsn Opcodes/ISTORE 1) ;;
- (.visitJumpInsn Opcodes/GOTO $begin)
- (.visitLabel $not-right) ;; tag, sum-tag
- (.visitInsn Opcodes/POP2)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; I commented-out some parts because a null-check was
- ;; done to ensure variants were never created with null
- ;; values (this would interfere later with
- ;; pattern-matching).
- ;; Since Lux itself doesn't have null values as part of
- ;; the language, the burden of ensuring non-nulls was
- ;; shifted to library code dealing with host-interop, to
- ;; ensure variant-making was as fast as possible.
- ;; The null-checking code was left as comments in case I
- ;; ever change my mind.
- _ (let [;; $is-null (new Label)
- ]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
- (.visitCode)
- ;; (.visitVarInsn Opcodes/ALOAD 2)
- ;; (.visitJumpInsn Opcodes/IFNULL $is-null)
- (.visitLdcInsn (int 3))
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ILOAD 0)
- (&&/wrap-int)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 2))
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/ARETURN)
- ;; (.visitLabel $is-null)
- ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
- ;; (.visitInsn Opcodes/DUP)
- ;; (.visitLdcInsn "Can't create variant for null pointer")
- ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
- ;; (.visitInsn Opcodes/ATHROW)
- (.visitMaxs 0 0)
- (.visitEnd)))]
- nil))
-
-(defn ^:private low-4b [^MethodVisitor =method]
- (doto =method
- ;; Assume there is a long at the top of the stack...
- ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits.
- (.visitLdcInsn (int -1))
- (.visitInsn Opcodes/I2L)
- ;; Then do a bitwise and.
- (.visitInsn Opcodes/LAND)
- ))
-
-(defn ^:private high-4b [^MethodVisitor =method]
- (doto =method
- ;; Assume there is a long at the top of the stack...
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- ))
-
-(defn ^:private swap2 [^MethodVisitor =method]
- (doto =method
- ;; X2, Y2
- (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2
- (.visitInsn Opcodes/POP2) ;; Y2, X2
- ))
-
-(defn ^:private swap2x1 [^MethodVisitor =method]
- (doto =method
- ;; X1, Y2
- (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2
- (.visitInsn Opcodes/POP2) ;; Y2, X1
- ))
-
-(defn ^:private bit-set-64? [^MethodVisitor =method]
- (doto =method
- ;; L, I
- (.visitLdcInsn (long 1)) ;; L, I, L
- (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L
- (.visitInsn Opcodes/POP2) ;; L, L, I
- (.visitInsn Opcodes/LSHL) ;; L, L
- (.visitInsn Opcodes/LAND) ;; L
- (.visitLdcInsn (long 0)) ;; L, L
- (.visitInsn Opcodes/LCMP) ;; I
- ))
-
-(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class]
- (|let [deg-bits 64
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil)
- ;; Based on: http://stackoverflow.com/a/31629280/6823464
- (.visitCode)
- ;; Bottom part
- (.visitVarInsn Opcodes/LLOAD 0) low-4b
- (.visitVarInsn Opcodes/LLOAD 2) low-4b
- (.visitInsn Opcodes/LMUL)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- ;; Middle part
- (.visitVarInsn Opcodes/LLOAD 0) high-4b
- (.visitVarInsn Opcodes/LLOAD 2) low-4b
- (.visitInsn Opcodes/LMUL)
- (.visitVarInsn Opcodes/LLOAD 0) low-4b
- (.visitVarInsn Opcodes/LLOAD 2) high-4b
- (.visitInsn Opcodes/LMUL)
- (.visitInsn Opcodes/LADD)
- ;; Join middle and bottom
- (.visitInsn Opcodes/LADD)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- ;; Top part
- (.visitVarInsn Opcodes/LLOAD 0) high-4b
- (.visitVarInsn Opcodes/LLOAD 2) high-4b
- (.visitInsn Opcodes/LMUL)
- ;; Join top with rest
- (.visitInsn Opcodes/LADD)
- ;; Return
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil)
- (.visitCode)
- ;; Based on: http://stackoverflow.com/a/8510587/6823464
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2) high-4b
- (.visitInsn Opcodes/LDIV)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LSHL)
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil)
- (.visitCode)
- ;; Translate high bytes
- (.visitVarInsn Opcodes/LLOAD 0) high-4b
- (.visitInsn Opcodes/L2D)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DDIV)
- ;; Translate low bytes
- (.visitVarInsn Opcodes/LLOAD 0) low-4b
- (.visitInsn Opcodes/L2D)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DDIV)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DDIV)
- ;; Combine and return
- (.visitInsn Opcodes/DADD)
- (.visitInsn Opcodes/DRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil)
- (.visitCode)
- ;; Drop any excess
- (.visitVarInsn Opcodes/DLOAD 0)
- (.visitLdcInsn (double 1.0))
- (.visitInsn Opcodes/DREM)
- ;; Shift upper half, but retain remaining decimals
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DMUL)
- ;; Make a copy, so the lower half can be extracted
- (.visitInsn Opcodes/DUP2)
- ;; Get that lower half
- (.visitLdcInsn (double 1.0))
- (.visitInsn Opcodes/DREM)
- (.visitLdcInsn (double (Math/pow 2 32)))
- (.visitInsn Opcodes/DMUL)
- ;; Turn it into a deg
- (.visitInsn Opcodes/D2L)
- ;; Turn the upper half into deg too
- swap2
- (.visitInsn Opcodes/D2L)
- ;; Combine both pieces
- (.visitInsn Opcodes/LADD)
- ;; FINISH
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil)
- (.visitCode)
- (.visitLdcInsn (int 0)) ;; {carry}
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 0)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; {carry}
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ILOAD 0)
- (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit}
- (.visitLdcInsn (int 5))
- (.visitInsn Opcodes/IMUL)
- (.visitInsn Opcodes/IADD) ;; {next-raw-digit}
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 10))
- (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit}
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ILOAD 0)
- swap2x1
- (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit}
- (.visitLdcInsn (int 10))
- (.visitInsn Opcodes/IDIV) ;; {next-carry}
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 0)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil)
- (.visitCode)
- ;; Initialize digits array.
- (.visitLdcInsn (int deg-bits))
- (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits}
- (.visitInsn Opcodes/DUP)
- (.visitVarInsn Opcodes/ILOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/BASTORE) ;; digits = 5^0
- (.visitVarInsn Opcodes/ASTORE 1)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitVarInsn Opcodes/ILOAD 0) ;; {times}
- (.visitLabel $loop-start)
- (.visitInsn Opcodes/DUP)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- ;; {times}
- (.visitVarInsn Opcodes/ILOAD 0)
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times}
- (.visitVarInsn Opcodes/ASTORE 1) ;; {times}
- ;; Decrement index
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- ;; {times-1}
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil)
- (.visitCode)
- (.visitLdcInsn (int (dec deg-bits)))
- (.visitVarInsn Opcodes/ISTORE 2) ;; Index
- (.visitLdcInsn (int deg-bits))
- (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
- (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits
- (.visitLdcInsn (int 0)) ;; {carry}
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; {carry}
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- ;; {carry}
- (.visitVarInsn Opcodes/ALOAD 3)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; {carry}
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitInsn Opcodes/BALOAD) ;; {carry, dL}
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR}
- (.visitInsn Opcodes/IADD)
- (.visitInsn Opcodes/IADD) ;; {raw-next-digit}
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 10))
- (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit}
- (.visitVarInsn Opcodes/ALOAD 3)
- (.visitVarInsn Opcodes/ILOAD 2)
- swap2x1
- (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit}
- (.visitLdcInsn (int 10))
- (.visitInsn Opcodes/IDIV) ;; {next-carry}
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 2)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil)
- (.visitCode)
- (.visitLdcInsn (int (dec deg-bits)))
- (.visitVarInsn Opcodes/ISTORE 1) ;; Index
- (.visitLdcInsn "") ;; {text}
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitInsn Opcodes/BALOAD) ;; {text, digit}
- (.visitLdcInsn (int 10)) ;; {text, digit, radix}
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char}
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text}
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 1)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)
- $not-set (new Label)
- $next-iteration (new Label)
- $normal-path (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil)
- (.visitCode)
- ;; A quick corner-case to handle.
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFNE $normal-path)
- (.visitLdcInsn ".0")
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $normal-path)
- ;; Normal case
- (.visitLdcInsn (int (dec deg-bits)))
- (.visitVarInsn Opcodes/ISTORE 2) ;; Index
- (.visitLdcInsn (int deg-bits))
- (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
- (.visitVarInsn Opcodes/ASTORE 3) ;; digits
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- ;; Prepare text to return.
- (.visitVarInsn Opcodes/ALOAD 3)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;")
- (.visitLdcInsn ".")
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- ;; Trim unnecessary 0s at the end...
- (.visitLdcInsn "0*$")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;")
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/AALOAD)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/ILOAD 2)
- bit-set-64?
- (.visitJumpInsn Opcodes/IFEQ $next-iteration)
- (.visitLdcInsn (int (dec deg-bits)))
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitInsn Opcodes/ISUB)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B")
- (.visitVarInsn Opcodes/ALOAD 3)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B")
- (.visitVarInsn Opcodes/ASTORE 3)
- (.visitJumpInsn Opcodes/GOTO $next-iteration)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $next-iteration)
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 2)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)
- $not-set (new Label)
- $next-iteration (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 1) ;; Index
- (.visitLdcInsn (int deg-bits))
- (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
- (.visitVarInsn Opcodes/ASTORE 2) ;; digits
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/IADD)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B")
- ;; Set digit
- (.visitVarInsn Opcodes/ALOAD 2)
- (.visitVarInsn Opcodes/ILOAD 1)
- swap2x1
- (.visitInsn Opcodes/BASTORE)
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 1)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)
- $is-less-than (new Label)
- $is-equal (new Label)]
- ;; [B0 <= [B1
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil)
- (.visitCode)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ISTORE 2) ;; Index
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitLdcInsn (int deg-bits))
- (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round)
- (.visitLdcInsn false)
- (.visitInsn Opcodes/IRETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitInsn Opcodes/BALOAD) ;; {D0}
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitInsn Opcodes/BALOAD) ;; {D0, D1}
- (.visitInsn Opcodes/DUP2)
- (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than)
- (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal)
- ;; Is greater than...
- (.visitLdcInsn false)
- (.visitInsn Opcodes/IRETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $is-less-than)
- (.visitInsn Opcodes/POP2)
- (.visitLdcInsn true)
- (.visitInsn Opcodes/IRETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $is-equal)
- ;; Increment index
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/IADD)
- (.visitVarInsn Opcodes/ISTORE 2)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)
- $simple-sub (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil)
- (.visitCode)
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit}
- (.visitInsn Opcodes/BALOAD)
- (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit}
- (.visitInsn Opcodes/DUP2)
- (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;; Since $0 < $1
- (.visitInsn Opcodes/SWAP)
- (.visitInsn Opcodes/ISUB) ;; $1 - $0
- (.visitLdcInsn (byte 10))
- (.visitInsn Opcodes/SWAP)
- (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 2)
- swap2x1
- (.visitInsn Opcodes/BASTORE)
- ;; Prepare to iterate...
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 2)
- ;; Subtract 1 from next digit
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ISTORE 1)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $simple-sub)
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 2)
- swap2x1
- (.visitInsn Opcodes/BASTORE)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$loop-start (new Label)
- $do-a-round (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil)
- (.visitCode)
- (.visitLdcInsn (int (dec deg-bits)))
- (.visitVarInsn Opcodes/ISTORE 2) ;; Index
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitJumpInsn Opcodes/IFGE $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits}
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit}
- (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx}
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B")
- (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits
- ;; Decrement index
- (.visitVarInsn Opcodes/ILOAD 2)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitVarInsn Opcodes/ISTORE 2)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- (.visitMaxs 0 0)
- (.visitEnd)))
- _ (let [$from (new Label)
- $to (new Label)
- $handler (new Label)
- $loop-start (new Label)
- $do-a-round (new Label)
- $skip-power (new Label)
- $iterate (new Label)
- $bad-format (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- ;; Check prefix
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn ".")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z")
- (.visitJumpInsn Opcodes/IFEQ $bad-format)
- ;; Check if size is valid
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix .
- (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format)
- ;; Initialization
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitLabel $from)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B")
- (.visitLabel $to)
- (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits...
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ISTORE 1) ;; Index
- (.visitLdcInsn (long 0))
- (.visitVarInsn Opcodes/LSTORE 2) ;; Output
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $loop-start)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitLdcInsn (int deg-bits))
- (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round)
- (.visitVarInsn Opcodes/LLOAD 2)
- &&/wrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $do-a-round)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B")
- (.visitInsn Opcodes/DUP2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z")
- (.visitJumpInsn Opcodes/IFNE $skip-power)
- ;; Subtract power
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B")
- (.visitVarInsn Opcodes/ASTORE 0)
- ;; Set bit on output
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitLdcInsn (long 1))
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitLdcInsn (int (dec deg-bits)))
- (.visitInsn Opcodes/SWAP)
- (.visitInsn Opcodes/ISUB)
- (.visitInsn Opcodes/LSHL)
- (.visitInsn Opcodes/LOR)
- (.visitVarInsn Opcodes/LSTORE 2)
- (.visitJumpInsn Opcodes/GOTO $iterate)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $skip-power)
- (.visitInsn Opcodes/POP2)
- ;; (.visitJumpInsn Opcodes/GOTO $iterate)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $iterate)
- (.visitVarInsn Opcodes/ILOAD 1)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/IADD)
- (.visitVarInsn Opcodes/ISTORE 1)
- ;; Iterate
- (.visitJumpInsn Opcodes/GOTO $loop-start)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $handler)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitLabel $bad-format)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))]
- nil))
-
-(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
- (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class]
- (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677
- _ (let [$from (new Label)
- $to (new Label)
- $handler (new Label)
-
- $good-start (new Label)
- $short-enough (new Label)
- $bad-digit (new Label)
- $out-of-bounds (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from)
- ;; Remove the + at the beginning...
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 0))
- (.visitLdcInsn (int 1))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitLdcInsn "+")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
- (.visitJumpInsn Opcodes/IFNE $good-start)
- ;; Doesn't start with +
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; Starts with +
- (.visitLabel $good-start)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix...
- ;; Begin parsing processs
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 18))
- (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough)
- ;; Too long
- ;; Get prefix...
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
- (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later...
- ;; Get last digit...
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/ISUB)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C")
- (.visitLdcInsn (int 10))
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I")
- ;; Test last digit...
- (.visitInsn Opcodes/DUP)
- (.visitJumpInsn Opcodes/IFLT $bad-digit)
- ;; Good digit...
- ;; Stack: prefix::L, prefix::L, last-digit::I
- (.visitInsn Opcodes/I2L)
- ;; Build the result...
- swap2
- (.visitLdcInsn (long 10))
- (.visitInsn Opcodes/LMUL)
- (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L
- (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L
- swap2 ;; Stack: result::L, result::L, prefix::L
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitJumpInsn Opcodes/IFLT $out-of-bounds)
- ;; Within bounds
- ;; Stack: result::L
- &&/wrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; Out of bounds
- (.visitLabel $out-of-bounds)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; Bad digit...
- (.visitLabel $bad-digit)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- ;; 18 chars or less
- (.visitLabel $short-enough)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
- &&/wrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitLabel $to)
- (.visitLabel $handler)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172
- _ (let [$too-big (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil)
- (.visitCode)
- (.visitLdcInsn "+")
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLT $too-big)
- ;; then
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/ARETURN)
- ;; else
- (.visitLabel $too-big)
- ;; Set up parts of the number string...
- ;; First digits
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/LUSHR)
- (.visitLdcInsn (long 5))
- (.visitInsn Opcodes/LDIV) ;; quot
- ;; Last digit
- (.visitInsn Opcodes/DUP2)
- (.visitLdcInsn (long 10))
- (.visitInsn Opcodes/LMUL)
- (.visitVarInsn Opcodes/LLOAD 0)
- swap2
- (.visitInsn Opcodes/LSUB) ;; quot, rem
- ;; Conversion to string...
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem*
- (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem*
- (.visitInsn Opcodes/POP) ;; rem*, quot
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot*
- (.visitInsn Opcodes/SWAP) ;; quot*, rem*
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
- _ (let [$simple-case (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFGE $simple-case)
- ;; else
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
- (.visitLdcInsn (int 32))
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;")
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LSHL)
- (.visitLdcInsn (int 32))
- (.visitInsn Opcodes/LUSHR)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
- (.visitInsn Opcodes/ARETURN)
- ;; then
- (.visitLabel $simple-case)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
- (.visitInsn Opcodes/LADD)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
- (.visitInsn Opcodes/LADD)
- (.visitInsn Opcodes/LCMP)
- (.visitInsn Opcodes/IRETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
- _ (let [$case-1 (new Label)
- $0 (new Label)
- $case-2 (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil)
- (.visitCode)
- ;; Test #1
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLT $case-1)
- ;; Test #2
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFGT $case-2)
- ;; Case #3
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
- (.visitInsn Opcodes/LRETURN)
- ;; Case #2
- (.visitLabel $case-2)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitInsn Opcodes/LDIV)
- (.visitInsn Opcodes/LRETURN)
- ;; Case #1
- (.visitLabel $case-1)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitJumpInsn Opcodes/IFLT $0)
- ;; 1
- (.visitLdcInsn (long 1))
- (.visitInsn Opcodes/LRETURN)
- ;; 0
- (.visitLabel $0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LRETURN)
- (.visitMaxs 0 0)
- (.visitEnd)))
- ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
- _ (let [$test-2 (new Label)
- $case-2 (new Label)]
- (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil)
- (.visitCode)
- ;; Test #1
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLE $test-2)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitLdcInsn (long 0))
- (.visitInsn Opcodes/LCMP)
- (.visitJumpInsn Opcodes/IFLE $test-2)
- ;; Case #1
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitInsn Opcodes/LREM)
- (.visitInsn Opcodes/LRETURN)
- ;; Test #2
- (.visitLabel $test-2)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitJumpInsn Opcodes/IFLT $case-2)
- ;; Case #3
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitVarInsn Opcodes/LLOAD 2)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
- (.visitInsn Opcodes/LRETURN)
- ;; Case #2
- (.visitLabel $case-2)
- (.visitVarInsn Opcodes/LLOAD 0)
- (.visitInsn Opcodes/LRETURN)
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (.visitMaxs 0 0)
- (.visitEnd)))]
- nil)))
-
-(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class]
- (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil)
- (.visitCode)
- (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn "Invalid expression for pattern-matching.")
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
- (.visitInsn Opcodes/ATHROW)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLdcInsn (int 2))
- (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 0))
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int 1))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitInsn Opcodes/AASTORE)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/AALOAD)
- (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn (int 1))
- (.visitInsn Opcodes/AALOAD)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]
- nil))
-
-(def compile-LuxRT-class
- (|do [_ (return nil)
- :let [full-name &&/lux-utils-class
- super-class (&host-generics/->bytecode-class-name "java.lang.Object")
- tag-sig (&host-generics/->type-signature "java.lang.String")
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- full-name nil super-class (into-array String [])))
- =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag)
- (.visitEnd))
- =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
- (.visitLdcInsn "LOG: ")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V")
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V")
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I
- (.visitInsn Opcodes/ACONST_NULL) ;; I?
- (.visitLdcInsn &/unit-tag) ;; I?U
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
- (.visitCode)
- (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I
- (.visitLdcInsn "") ;; I?
- (.visitVarInsn Opcodes/ALOAD 0) ;; I?O
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitLdcInsn "_")
- (.visitLdcInsn "")
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;")
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- _ (doto =class
- (compile-LuxRT-pm-methods)
- (compile-LuxRT-adt-methods)
- (compile-LuxRT-nat-methods)
- (compile-LuxRT-deg-methods))]]
- (&&/save-class! (second (string/split &&/lux-utils-class #"/"))
- (.toByteArray (doto =class .visitEnd)))))
-
-(defn ^:private compile-jvm-try [compile ?values special-args]
- (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- :let [$from (new Label)
- $to (new Label)
- $handler (new Label)
- $end (new Label)]
- :let [_ (doto *writer*
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from))]
- _ (compile ?body)
- :let [_ (doto *writer*
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $to)
- (.visitLabel $handler))]
- _ (compile ?catch)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
- :let [_ (.visitLabel *writer* $end)]]
- (return nil)))
-
-(do-template [<name> <op> <unwrap> <wrap>]
- (defn <name> [compile _?value special-args]
- (|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?value)
- :let [_ (doto *writer*
- <unwrap>
- (.visitInsn <op>)
- <wrap>)]]
- (return nil)))
-
- ^:private compile-jvm-d2f Opcodes/D2F &&/unwrap-double &&/wrap-float
- ^:private compile-jvm-d2i Opcodes/D2I &&/unwrap-double &&/wrap-int
- ^:private compile-jvm-d2l Opcodes/D2L &&/unwrap-double &&/wrap-long
-
- ^:private compile-jvm-f2d Opcodes/F2D &&/unwrap-float &&/wrap-double
- ^:private compile-jvm-f2i Opcodes/F2I &&/unwrap-float &&/wrap-int
- ^:private compile-jvm-f2l Opcodes/F2L &&/unwrap-float &&/wrap-long
-
- ^:private compile-jvm-i2b Opcodes/I2B &&/unwrap-int &&/wrap-byte
- ^:private compile-jvm-i2c Opcodes/I2C &&/unwrap-int &&/wrap-char
- ^:private compile-jvm-i2d Opcodes/I2D &&/unwrap-int &&/wrap-double
- ^:private compile-jvm-i2f Opcodes/I2F &&/unwrap-int &&/wrap-float
- ^:private compile-jvm-i2l Opcodes/I2L &&/unwrap-int &&/wrap-long
- ^:private compile-jvm-i2s Opcodes/I2S &&/unwrap-int &&/wrap-short
-
- ^:private compile-jvm-l2d Opcodes/L2D &&/unwrap-long &&/wrap-double
- ^:private compile-jvm-l2f Opcodes/L2F &&/unwrap-long &&/wrap-float
- ^:private compile-jvm-l2i Opcodes/L2I &&/unwrap-long &&/wrap-int
-
- ^:private compile-jvm-c2b Opcodes/I2B &&/unwrap-char &&/wrap-byte
- ^:private compile-jvm-c2s Opcodes/I2S &&/unwrap-char &&/wrap-short
- ^:private compile-jvm-c2i Opcodes/NOP &&/unwrap-char &&/wrap-int
- ^:private compile-jvm-c2l Opcodes/I2L &&/unwrap-char &&/wrap-long
-
- ^:private compile-jvm-s2l Opcodes/I2L &&/unwrap-short &&/wrap-long
-
- ^:private compile-jvm-b2l Opcodes/I2L &&/unwrap-byte &&/wrap-long
- )
-
-(do-template [<name> <op> <wrap>]
- (defn <name> [compile _?value special-args]
- (|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?value)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I)
- (.visitInsn <op>)
- <wrap>)]]
- (return nil)))
-
- ^:private compile-jvm-l2s Opcodes/I2S &&/wrap-short
- ^:private compile-jvm-l2b Opcodes/I2B &&/wrap-byte
- )
-
-(do-template [<name> <op> <unwrap-left> <unwrap-right> <wrap>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap-left>)]
- _ (compile ?y)
- :let [_ (doto *writer*
- <unwrap-right>)]
- :let [_ (doto *writer*
- (.visitInsn <op>)
- <wrap>)]]
- (return nil)))
-
- ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int
-
- ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long
- ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long
- ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long
- )
-
-(do-template [<name> <opcode> <unwrap> <wrap>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>)]
- _ (compile ?y)
- :let [_ (doto *writer*
- <unwrap>)
- _ (doto *writer*
- (.visitInsn <opcode>)
- (<wrap>))]]
- (return nil)))
-
- ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int
- ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int
-
- ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long
- ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long
-
- ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float
- ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float
- ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float
- ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float
- ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float
-
- ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double
- ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double
- ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double
- ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double
- ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double
- )
-
-(do-template [<name> <opcode> <unwrap>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>)]
- _ (compile ?y)
- :let [_ (doto *writer*
- <unwrap>)
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitJumpInsn <opcode> $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
- ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int
- ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int
- ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int
-
- ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char
- ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char
- ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char
- )
-
-(do-template [<name> <cmpcode> <cmp-output> <unwrap>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>)]
- _ (compile ?y)
- :let [_ (doto *writer*
- <unwrap>)
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitInsn <cmpcode>)
- (.visitLdcInsn (int <cmp-output>))
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
- ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long
- ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long
- ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long
-
- ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float
- ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float
- ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float
-
- ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double
- ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double
- ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double
- )
-
-(do-template [<prim-type> <array-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>]
- (do (defn <new-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?length)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]]
- (return nil)))
-
- (defn <load-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (doto *writer*
- (.visitInsn <load-op>)
- <wrapper>)]]
- (return nil)))
-
- (defn <store-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
- :let [_ (.visitInsn *writer* Opcodes/DUP)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- _ (compile ?elem)
- :let [_ (doto *writer*
- <unwrapper>
- (.visitInsn <store-op>))]]
- (return nil)))
- )
-
- Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean
- Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte
- Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short
- Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int
- Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long
- Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float
- Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double
- Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
- )
-
-(defn ^:private compile-jvm-anewarray [compile ?values special-args]
- (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
- (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?length)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]]
- (return nil)))
-
-(defn ^:private compile-jvm-aaload [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitInsn *writer* Opcodes/AALOAD)]]
- (return nil)))
-
-(defn ^:private compile-jvm-aastore [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- :let [_ (.visitInsn *writer* Opcodes/DUP)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- _ (compile ?elem)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return nil)))
-
-(defn ^:private compile-jvm-arraylength [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARRAYLENGTH)
- (.visitInsn Opcodes/I2L)
- &&/wrap-long)]]
- (return nil)))
-
-(defn ^:private compile-jvm-null [compile ?values special-args]
- (|do [:let [;; (&/$Nil) ?values
- (&/$Nil) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
- (return nil)))
-
-(defn ^:private compile-jvm-null? [compile ?values special-args]
- (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?object)
- :let [$then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitJumpInsn Opcodes/IFNULL $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
-(defn compile-jvm-synchronized [compile ?values special-args]
- (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?monitor)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitInsn Opcodes/MONITORENTER))]
- _ (compile ?expr)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/SWAP)
- (.visitInsn Opcodes/MONITOREXIT))]]
- (return nil)))
-
-(defn ^:private compile-jvm-throw [compile ?values special-args]
- (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?ex)
- :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
- (return nil)))
-
-(defn ^:private compile-jvm-getstatic [compile ?values special-args]
- (|do [:let [;; (&/$Nil) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
- ^MethodVisitor *writer* &/get-writer
- =output-type (&host/->java-sig ?output-type)
- :let [_ (doto *writer*
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type)
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(defn ^:private compile-jvm-getfield [compile ?values special-args]
- (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
- :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?object)
- =output-type (&host/->java-sig ?output-type)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST class*)
- (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type)
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(defn ^:private compile-jvm-putstatic [compile ?values special-args]
- (|do [:let [(&/$Cons ?value (&/$Nil)) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?value)
- :let [=input-sig (&host-type/gclass->sig input-gclass)
- _ (doto *writer*
- (prepare-arg! (&host-generics/gclass->class-name input-gclass))
- (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig)
- (.visitInsn Opcodes/ACONST_NULL))]]
- (return nil)))
-
-(defn ^:private compile-jvm-putfield [compile ?values special-args]
- (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values
- (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args]
- :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)]
- _ (compile ?value)
- =input-sig (&host/->java-sig ?input-type)
- :let [_ (doto *writer*
- (prepare-arg! (&host-generics/gclass->class-name input-gclass))
- (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig)
- (.visitInsn Opcodes/ACONST_NULL))]]
- (return nil)))
-
-(defn ^:private compile-jvm-invokestatic [compile ?values special-args]
- (|do [:let [?args ?values
- (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
- _ (&/map2% (fn [class-name arg]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- ?classes ?args)
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig)
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?object ?args) ?values
- (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
- :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
- ^MethodVisitor *writer* &/get-writer
- :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
- _ (compile ?object)
- :let [_ (when (not= "<init>" ?method)
- (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
- _ (&/map2% (fn [class-name arg]
- (|do [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- ?classes ?args)
- :let [_ (doto *writer*
- (.visitMethodInsn <op> ?class* ?method method-sig)
- (prepare-return! ?output-type))]]
- (return nil)))
-
- ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL
- ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE
- ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL
- )
-
-(defn ^:private compile-jvm-new [compile ?values special-args]
- (|do [:let [?args ?values
- (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V")
- class* (&host-generics/->bytecode-class-name ?class)
- _ (doto *writer*
- (.visitTypeInsn Opcodes/NEW class*)
- (.visitInsn Opcodes/DUP))]
- _ (&/map% (fn [class-name+arg]
- (|do [:let [[class-name arg] class-name+arg]
- ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (&/zip2 ?classes ?args))
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
- (return nil)))
-
-(defn ^:private compile-jvm-try [compile ?values special-args]
- (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- :let [$from (new Label)
- $to (new Label)
- $handler (new Label)
- $end (new Label)]
- :let [_ (doto *writer*
- (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
- (.visitLabel $from))]
- _ (compile ?body)
- :let [_ (doto *writer*
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $to)
- (.visitLabel $handler))]
- _ (compile ?catch)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
- (.visitInsn Opcodes/SWAP)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
- :let [_ (.visitLabel *writer* $end)]]
- (return nil)))
-
-(defn ^:private compile-jvm-load-class [compile ?values special-args]
- (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- (.visitLdcInsn _class-name)
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;")
- (prepare-return! ?output-type))]]
- (return nil)))
-
-(defn ^:private compile-jvm-instanceof [compile ?values special-args]
- (|do [:let [(&/$Cons object (&/$Nil)) ?values
- (&/$Cons class (&/$Nil)) special-args]
- :let [class* (&host-generics/->bytecode-class-name class)]
- ^MethodVisitor *writer* &/get-writer
- _ (compile object)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/INSTANCEOF class*)
- (&&/wrap-boolean))]]
- (return nil)))
-
-(defn ^:private compile-array-get [compile ?values special-args]
- (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
- ;; (&/$Nil) special-args
- ]
- ^MethodVisitor *writer* &/get-writer
- array-type (&host/->java-sig (&a/expr-type* ?array))
- _ (compile ?array)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
- _ (compile ?idx)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (.visitInsn *writer* Opcodes/AALOAD)]
- :let [$is-null (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitJumpInsn Opcodes/IFNULL $is-null)
- (.visitLdcInsn (int 1))
- (.visitLdcInsn "")
- (.visitInsn Opcodes/DUP2_X1) ;; I?2I?
- (.visitInsn Opcodes/POP2) ;; I?2
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $is-null)
- (.visitInsn Opcodes/POP)
- (.visitLdcInsn (int 0))
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitLdcInsn &/unit-tag)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
- (.visitLabel $end))]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (&&/unwrap-long *writer*)]
- _ (compile ?mask)
- :let [_ (&&/unwrap-long *writer*)]
- :let [_ (doto *writer*
- (.visitInsn <op>)
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-bit-and Opcodes/LAND
- ^:private compile-bit-or Opcodes/LOR
- ^:private compile-bit-xor Opcodes/LXOR
- )
-
-(defn ^:private compile-bit-count [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (&&/unwrap-long *writer*)]
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I")
- (.visitInsn Opcodes/I2L)
- &&/wrap-long)]]
- (return nil)))
-
-(do-template [<name> <op>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?input)
- :let [_ (&&/unwrap-long *writer*)]
- _ (compile ?shift)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitInsn Opcodes/L2I))]
- :let [_ (doto *writer*
- (.visitInsn <op>)
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-bit-shift-left Opcodes/LSHL
- ^:private compile-bit-shift-right Opcodes/LSHR
- ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR
- )
-
-(defn ^:private compile-lux-== [compile ?values special-args]
- (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?left)
- _ (compile ?right)
- :let [$then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitJumpInsn Opcodes/IF_ACMPEQ $then)
- ;; else
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;")
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;")
- (.visitLabel $end))]]
- (return nil)))
-
-(do-template [<name> <opcode>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long)]
- _ (compile ?y)
- :let [_ (doto *writer*
- &&/unwrap-long)
- _ (doto *writer*
- (.visitInsn <opcode>)
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-nat-add Opcodes/LADD
- ^:private compile-nat-sub Opcodes/LSUB
- ^:private compile-nat-mul Opcodes/LMUL
-
- ^:private compile-deg-add Opcodes/LADD
- ^:private compile-deg-sub Opcodes/LSUB
- ^:private compile-deg-rem Opcodes/LSUB
- ^:private compile-deg-scale Opcodes/LMUL
- )
-
-(do-template [<name> <comp-method>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long)]
- _ (compile ?y)
- :let [_ (doto *writer*
- &&/unwrap-long)
- _ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <comp-method> "(JJ)J")
- (&&/wrap-long))]]
- (return nil)))
-
- ^:private compile-nat-div "div_nat"
- ^:private compile-nat-rem "rem_nat"
- )
-
-(do-template [<name> <cmp-output>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long)]
- _ (compile ?y)
- :let [_ (doto *writer*
- &&/unwrap-long)
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitLdcInsn (int <cmp-output>))
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
- ^:private compile-nat-eq 0
-
- ^:private compile-deg-eq 0
- ^:private compile-deg-lt -1
- )
-
-(defn ^:private compile-nat-lt [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long)]
- _ (compile ?y)
- :let [_ (doto *writer*
- &&/unwrap-long)
- $then (new Label)
- $end (new Label)
- _ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
- (.visitLdcInsn (int -1))
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $then)
- (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
- (.visitLabel $end))]]
- (return nil)))
-
-(do-template [<name> <instr> <wrapper>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Nil) ?values]
- ^MethodVisitor *writer* &/get-writer
- :let [_ (doto *writer*
- <instr>
- <wrapper>)]]
- (return nil)))
-
- ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long
- ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long
-
- ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long
- ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long
- )
-
-(do-template [<encode-name> <encode-method> <decode-name> <decode-method>]
- (do (defn <encode-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <encode-method> "(J)Ljava/lang/String;"))]]
- (return nil)))
-
- (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")]
- (defn <decode-name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <decode-method> "(Ljava/lang/String;)Ljava/lang/Object;"))]]
- (return nil)))))
-
- ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat"
- ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg"
- )
-
-(do-template [<name> <method>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- &&/unwrap-long)]
- _ (compile ?y)
- :let [_ (doto *writer*
- &&/unwrap-long)]
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(JJ)J")
- &&/wrap-long)]]
- (return nil)))
-
- ^:private compile-deg-mul "mul_deg"
- ^:private compile-deg-div "div_deg"
- )
-
-(do-template [<name> <class> <method> <sig> <unwrap> <wrap>]
- (let [+wrapper-class+ (&host-generics/->bytecode-class-name <class>)]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>
- (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> <sig>)
- <wrap>)]]
- (return nil))))
-
- ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double
- ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long
- )
-
-(let [widen (fn [^MethodVisitor *writer*]
- (doto *writer*
- (.visitInsn Opcodes/I2L)))
- shrink (fn [^MethodVisitor *writer*]
- (doto *writer*
- (.visitInsn Opcodes/L2I)
- (.visitInsn Opcodes/I2C)))]
- (do-template [<name> <unwrap> <wrap> <adjust>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- <unwrap>
- <adjust>
- <wrap>)]]
- (return nil)))
-
- ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink
- ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen
- ))
-
-(do-template [<name>]
- (defn <name> [compile ?values special-args]
- (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
- ^MethodVisitor *writer* &/get-writer
- _ (compile ?x)]
- (return nil)))
-
- ^:private compile-nat-to-int
- ^:private compile-int-to-nat
- )
-
-(defn compile-host [compile proc-category proc-name ?values special-args]
- (case proc-category
- "lux"
- (case proc-name
- "==" (compile-lux-== compile ?values special-args))
-
- "bit"
- (case proc-name
- "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)
- "shift-left" (compile-bit-shift-left compile ?values special-args)
- "shift-right" (compile-bit-shift-right compile ?values special-args)
- "unsigned-shift-right" (compile-bit-unsigned-shift-right compile ?values special-args))
-
- "array"
- (case proc-name
- "get" (compile-array-get compile ?values special-args))
-
- "nat"
- (case proc-name
- "+" (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)
- "encode" (compile-nat-encode compile ?values special-args)
- "decode" (compile-nat-decode compile ?values special-args)
- "max-value" (compile-nat-max-value compile ?values special-args)
- "min-value" (compile-nat-min-value compile ?values special-args)
- "to-int" (compile-nat-to-int compile ?values special-args)
- "to-char" (compile-nat-to-char compile ?values special-args)
- )
-
- "deg"
- (case proc-name
- "+" (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)
- "encode" (compile-deg-encode compile ?values special-args)
- "decode" (compile-deg-decode compile ?values special-args)
- "max-value" (compile-deg-max-value compile ?values special-args)
- "min-value" (compile-deg-min-value compile ?values special-args)
- "to-real" (compile-deg-to-real compile ?values special-args)
- "scale" (compile-deg-scale compile ?values special-args)
- )
-
- "int"
- (case proc-name
- "to-nat" (compile-int-to-nat compile ?values special-args)
- )
-
- "real"
- (case proc-name
- "to-deg" (compile-real-to-deg compile ?values special-args)
- )
-
- "char"
- (case proc-name
- "to-nat" (compile-char-to-nat compile ?values special-args)
- )
-
- "jvm"
- (case proc-name
- "synchronized" (compile-jvm-synchronized compile ?values special-args)
- "load-class" (compile-jvm-load-class compile ?values special-args)
- "instanceof" (compile-jvm-instanceof compile ?values special-args)
- "try" (compile-jvm-try compile ?values special-args)
- "new" (compile-jvm-new compile ?values special-args)
- "invokestatic" (compile-jvm-invokestatic compile ?values special-args)
- "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args)
- "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args)
- "invokespecial" (compile-jvm-invokespecial compile ?values special-args)
- "getstatic" (compile-jvm-getstatic compile ?values special-args)
- "getfield" (compile-jvm-getfield compile ?values special-args)
- "putstatic" (compile-jvm-putstatic compile ?values special-args)
- "putfield" (compile-jvm-putfield compile ?values special-args)
- "throw" (compile-jvm-throw compile ?values special-args)
- "null?" (compile-jvm-null? compile ?values special-args)
- "null" (compile-jvm-null compile ?values special-args)
- "anewarray" (compile-jvm-anewarray compile ?values special-args)
- "aaload" (compile-jvm-aaload compile ?values special-args)
- "aastore" (compile-jvm-aastore compile ?values special-args)
- "arraylength" (compile-jvm-arraylength compile ?values special-args)
- "znewarray" (compile-jvm-znewarray compile ?values special-args)
- "bnewarray" (compile-jvm-bnewarray compile ?values special-args)
- "snewarray" (compile-jvm-snewarray compile ?values special-args)
- "inewarray" (compile-jvm-inewarray compile ?values special-args)
- "lnewarray" (compile-jvm-lnewarray compile ?values special-args)
- "fnewarray" (compile-jvm-fnewarray compile ?values special-args)
- "dnewarray" (compile-jvm-dnewarray compile ?values special-args)
- "cnewarray" (compile-jvm-cnewarray compile ?values special-args)
- "iadd" (compile-jvm-iadd compile ?values special-args)
- "isub" (compile-jvm-isub compile ?values special-args)
- "imul" (compile-jvm-imul compile ?values special-args)
- "idiv" (compile-jvm-idiv compile ?values special-args)
- "irem" (compile-jvm-irem compile ?values special-args)
- "ieq" (compile-jvm-ieq compile ?values special-args)
- "ilt" (compile-jvm-ilt compile ?values special-args)
- "igt" (compile-jvm-igt compile ?values special-args)
- "ceq" (compile-jvm-ceq compile ?values special-args)
- "clt" (compile-jvm-clt compile ?values special-args)
- "cgt" (compile-jvm-cgt compile ?values special-args)
- "ladd" (compile-jvm-ladd compile ?values special-args)
- "lsub" (compile-jvm-lsub compile ?values special-args)
- "lmul" (compile-jvm-lmul compile ?values special-args)
- "ldiv" (compile-jvm-ldiv compile ?values special-args)
- "lrem" (compile-jvm-lrem compile ?values special-args)
- "leq" (compile-jvm-leq compile ?values special-args)
- "llt" (compile-jvm-llt compile ?values special-args)
- "lgt" (compile-jvm-lgt compile ?values special-args)
- "fadd" (compile-jvm-fadd compile ?values special-args)
- "fsub" (compile-jvm-fsub compile ?values special-args)
- "fmul" (compile-jvm-fmul compile ?values special-args)
- "fdiv" (compile-jvm-fdiv compile ?values special-args)
- "frem" (compile-jvm-frem compile ?values special-args)
- "feq" (compile-jvm-feq compile ?values special-args)
- "flt" (compile-jvm-flt compile ?values special-args)
- "fgt" (compile-jvm-fgt compile ?values special-args)
- "dadd" (compile-jvm-dadd compile ?values special-args)
- "dsub" (compile-jvm-dsub compile ?values special-args)
- "dmul" (compile-jvm-dmul compile ?values special-args)
- "ddiv" (compile-jvm-ddiv compile ?values special-args)
- "drem" (compile-jvm-drem compile ?values special-args)
- "deq" (compile-jvm-deq compile ?values special-args)
- "dlt" (compile-jvm-dlt compile ?values special-args)
- "dgt" (compile-jvm-dgt compile ?values special-args)
- "iand" (compile-jvm-iand compile ?values special-args)
- "ior" (compile-jvm-ior compile ?values special-args)
- "ixor" (compile-jvm-ixor compile ?values special-args)
- "ishl" (compile-jvm-ishl compile ?values special-args)
- "ishr" (compile-jvm-ishr compile ?values special-args)
- "iushr" (compile-jvm-iushr compile ?values special-args)
- "land" (compile-jvm-land compile ?values special-args)
- "lor" (compile-jvm-lor compile ?values special-args)
- "lxor" (compile-jvm-lxor compile ?values special-args)
- "lshl" (compile-jvm-lshl compile ?values special-args)
- "lshr" (compile-jvm-lshr compile ?values special-args)
- "lushr" (compile-jvm-lushr compile ?values special-args)
- "d2f" (compile-jvm-d2f compile ?values special-args)
- "d2i" (compile-jvm-d2i compile ?values special-args)
- "d2l" (compile-jvm-d2l compile ?values special-args)
- "f2d" (compile-jvm-f2d compile ?values special-args)
- "f2i" (compile-jvm-f2i compile ?values special-args)
- "f2l" (compile-jvm-f2l compile ?values special-args)
- "i2b" (compile-jvm-i2b compile ?values special-args)
- "i2c" (compile-jvm-i2c compile ?values special-args)
- "i2d" (compile-jvm-i2d compile ?values special-args)
- "i2f" (compile-jvm-i2f compile ?values special-args)
- "i2l" (compile-jvm-i2l compile ?values special-args)
- "i2s" (compile-jvm-i2s compile ?values special-args)
- "l2d" (compile-jvm-l2d compile ?values special-args)
- "l2f" (compile-jvm-l2f compile ?values special-args)
- "l2i" (compile-jvm-l2i compile ?values special-args)
- "l2s" (compile-jvm-l2s compile ?values special-args)
- "l2b" (compile-jvm-l2b compile ?values special-args)
- "c2b" (compile-jvm-c2b compile ?values special-args)
- "c2s" (compile-jvm-c2s compile ?values special-args)
- "c2i" (compile-jvm-c2i compile ?values special-args)
- "c2l" (compile-jvm-c2l compile ?values special-args)
- "s2l" (compile-jvm-s2l compile ?values special-args)
- "b2l" (compile-jvm-b2l compile ?values special-args)
- ;; else
- (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name])))
-
- ;; else
- (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))))
diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj
index 3ee19988f..f129fd3f0 100644
--- a/luxc/src/lux/compiler/io.clj
+++ b/luxc/src/lux/compiler/io.clj
@@ -1,6 +1,6 @@
(ns lux.compiler.io
(:require (lux [base :as & :refer [|case |let |do return* return fail*]])
- (lux.compiler [base :as &&])
+ (lux.compiler.jvm [base :as &&])
[lux.lib.loader :as &lib]))
;; [Utils]
@@ -10,17 +10,31 @@
(defn init-libs! []
(reset! !libs (&lib/load)))
-(defn read-file [source-dirs ^String file-name]
- (|case (&/|some (fn [^String source-dir]
- (let [file (new java.io.File source-dir file-name)]
- (if (.exists file)
- (&/$Some file)
- &/$None)))
- source-dirs)
- (&/$Some file)
- (return (slurp file))
+(defn read-file [source-dirs module-name]
+ (|do [jvm? &/jvm?
+ js? &/js?
+ :let [^String host-file-name (cond jvm? (str module-name ".jvm.lux")
+ js? (str module-name ".js.lux")
+ :else (assert false "[I/O Error] Unknown host platform."))
+ ^String lux-file-name (str module-name ".lux")]]
+ (|case (&/|some (fn [^String source-dir]
+ (let [host-file (new java.io.File source-dir host-file-name)
+ lux-file (new java.io.File source-dir lux-file-name)]
+ (cond (.exists host-file)
+ (&/$Some (&/T [host-file-name host-file]))
- (&/$None)
- (if-let [code (get @!libs file-name)]
- (return code)
- (&/fail-with-loc (str "[I/O Error] File doesn't exist: " file-name)))))
+ (.exists lux-file)
+ (&/$Some (&/T [lux-file-name lux-file]))
+
+ :else
+ &/$None)))
+ source-dirs)
+ (&/$Some [file-name file])
+ (return (&/T [file-name (slurp file)]))
+
+ (&/$None)
+ (if-let [code (get @!libs host-file-name)]
+ (return (&/T [host-file-name code]))
+ (if-let [code (get @!libs lux-file-name)]
+ (return (&/T [lux-file-name code]))
+ (&/fail-with-loc (str "[I/O Error] Module doesn't exist: " module-name)))))))
diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj
new file mode 100644
index 000000000..be405ad33
--- /dev/null
+++ b/luxc/src/lux/compiler/js.clj
@@ -0,0 +1,190 @@
+(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/$real ?value)
+ (&&lux/compile-real ?value)
+
+ (&o/$char ?value)
+ (&&lux/compile-char ?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/$var (&/$Global ?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] Can't 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 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
new file mode 100644
index 000000000..7f560b87d
--- /dev/null
+++ b/luxc/src/lux/compiler/js/base.clj
@@ -0,0 +1,243 @@
+(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
new file mode 100644
index 000000000..0945e6b5b
--- /dev/null
+++ b/luxc/src/lux/compiler/js/cache.clj
@@ -0,0 +1,40 @@
+(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
new file mode 100644
index 000000000..bf188803c
--- /dev/null
+++ b/luxc/src/lux/compiler/js/lux.clj
@@ -0,0 +1,391 @@
+(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-real [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.
+ ;; Won't 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/$RealPM _value)
+ (return (str "if(" cursor-peek " !== " _value ") { " pm-fail " }"))
+
+ (&o/$CharPM _value)
+ (|do [=value (compile-char _value)]
+ (return (str "if(" (str "(" cursor-peek ").C") " !== " (str "(" =value ").C") ") { " 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 (&/$IdentA [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: " module-name ";" ?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 (&/$BoolA 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 (&/$ListA 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*
+ (&/$TextA 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] Can't 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))]]
+ (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
new file mode 100644
index 000000000..cd67104f4
--- /dev/null
+++ b/luxc/src/lux/compiler/js/proc/common.clj
@@ -0,0 +1,612 @@
+(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-shift-left "shlI64"
+ ^:private compile-bit-shift-right "shrI64"
+ ^:private compile-bit-unsigned-shift-right "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"
+ )
+
+(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-real-add "+"
+ ^:private compile-real-sub "-"
+ ^:private compile-real-mul "*"
+ ^:private compile-real-div "/"
+ ^:private compile-real-rem "%"
+ ^:private compile-real-eq "==="
+ ^:private compile-real-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-int-encode "encodeI64"
+ ^:private compile-nat-encode "encodeN64"
+ ^:private compile-deg-encode "encodeD64"
+
+ ^:private compile-int-decode "decodeI64"
+ ^:private compile-nat-decode "decodeN64"
+ ^:private compile-deg-decode "decodeD64"
+
+ ^:private compile-real-decode "decodeReal"
+ )
+
+(defn ^:private compile-real-hash [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str "LuxRT$textHash(''+" =x ")"))
+ ))
+
+(do-template [<name> <compiler> <value>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values]]
+ (<compiler> <value>)))
+
+ ^:private compile-nat-min-value &&lux/compile-nat 0
+ ^:private compile-nat-max-value &&lux/compile-nat -1
+
+ ^:private compile-int-min-value &&lux/compile-int Long/MIN_VALUE
+ ^:private compile-int-max-value &&lux/compile-int Long/MAX_VALUE
+
+ ^:private compile-deg-min-value &&lux/compile-deg 0
+ ^:private compile-deg-max-value &&lux/compile-deg -1
+
+ ^:private compile-real-min-value &&lux/compile-real (* -1.0 Double/MAX_VALUE)
+ ^:private compile-real-max-value &&lux/compile-real Double/MAX_VALUE
+
+ ^:private compile-real-not-a-number &&lux/compile-real "NaN"
+ ^:private compile-real-positive-infinity &&lux/compile-real "Infinity"
+ ^:private compile-real-negative-infinity &&lux/compile-real "-Infinity"
+ )
+
+(defn ^:private compile-real-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-real [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str "LuxRT$toNumberI64(" =x ")"))))
+
+(defn ^:private compile-real-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-real [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str "LuxRT$degToReal(" =x ")"))))
+
+(defn ^:private compile-real-to-deg [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str "LuxRT$realToDeg(" =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-append [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) ")"))))
+
+(do-template [<name> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Nil)) ?values]
+ =text (compile ?text)]
+ (return (str "(" =text ")." <method> "()"))))
+
+ ^:private compile-text-trim "trim"
+ ^:private compile-text-upper-case "toUpperCase"
+ ^:private compile-text-lower-case "toLowerCase"
+ )
+
+(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-cosh "cosh"
+ ^:private compile-math-sinh "sinh"
+ ^:private compile-math-tanh "tanh"
+ ^:private compile-math-exp "exp"
+ ^:private compile-math-log "log"
+ ^:private compile-math-root2 "sqrt"
+ ^:private compile-math-root3 "cbrt"
+ ^:private compile-math-ceil "ceil"
+ ^:private compile-math-floor "floor"
+ ^:private compile-math-round "round"
+ )
+
+(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-atan2 "atan2"
+ ^: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)
+ "append" (compile-text-append 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)
+ "trim" (compile-text-trim compile ?values special-args)
+ "char" (compile-text-char compile ?values special-args)
+ "upper-case" (compile-text-upper-case compile ?values special-args)
+ "lower-case" (compile-text-lower-case 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)
+ "shift-left" (compile-bit-shift-left compile ?values special-args)
+ "shift-right" (compile-bit-shift-right compile ?values special-args)
+ "unsigned-shift-right" (compile-bit-unsigned-shift-right 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)
+ "encode" (compile-nat-encode compile ?values special-args)
+ "decode" (compile-nat-decode compile ?values special-args)
+ "max-value" (compile-nat-max-value compile ?values special-args)
+ "min-value" (compile-nat-min-value 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)
+ "encode" (compile-int-encode compile ?values special-args)
+ "decode" (compile-int-decode compile ?values special-args)
+ "max-value" (compile-int-max-value compile ?values special-args)
+ "min-value" (compile-int-min-value compile ?values special-args)
+ "to-nat" (compile-int-to-nat compile ?values special-args)
+ "to-real" (compile-int-to-real 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)
+ "encode" (compile-deg-encode compile ?values special-args)
+ "decode" (compile-deg-decode compile ?values special-args)
+ "max-value" (compile-deg-max-value compile ?values special-args)
+ "min-value" (compile-deg-min-value compile ?values special-args)
+ "to-real" (compile-deg-to-real compile ?values special-args)
+ "scale" (compile-deg-scale compile ?values special-args)
+ )
+
+ "real"
+ (case proc
+ "+" (compile-real-add compile ?values special-args)
+ "-" (compile-real-sub compile ?values special-args)
+ "*" (compile-real-mul compile ?values special-args)
+ "/" (compile-real-div compile ?values special-args)
+ "%" (compile-real-rem compile ?values special-args)
+ "=" (compile-real-eq compile ?values special-args)
+ "<" (compile-real-lt compile ?values special-args)
+ "encode" (compile-real-encode compile ?values special-args)
+ "decode" (compile-real-decode compile ?values special-args)
+ "max-value" (compile-real-max-value compile ?values special-args)
+ "min-value" (compile-real-min-value compile ?values special-args)
+ "not-a-number" (compile-real-not-a-number compile ?values special-args)
+ "positive-infinity" (compile-real-positive-infinity compile ?values special-args)
+ "negative-infinity" (compile-real-negative-infinity compile ?values special-args)
+ "to-deg" (compile-real-to-deg compile ?values special-args)
+ "to-int" (compile-real-to-int compile ?values special-args)
+ "hash" (compile-real-hash 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)
+ "cosh" (compile-math-cosh compile ?values special-args)
+ "sinh" (compile-math-sinh compile ?values special-args)
+ "tanh" (compile-math-tanh compile ?values special-args)
+ "exp" (compile-math-exp compile ?values special-args)
+ "log" (compile-math-log compile ?values special-args)
+ "root2" (compile-math-root2 compile ?values special-args)
+ "root3" (compile-math-root3 compile ?values special-args)
+ "ceil" (compile-math-ceil compile ?values special-args)
+ "floor" (compile-math-floor compile ?values special-args)
+ "round" (compile-math-round compile ?values special-args)
+ "atan2" (compile-math-atan2 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 host procedure: " [category proc]))))
diff --git a/luxc/src/lux/compiler/js/proc/host.clj b/luxc/src/lux/compiler/js/proc/host.clj
new file mode 100644
index 000000000..39bdb99c1
--- /dev/null
+++ b/luxc/src/lux/compiler/js/proc/host.clj
@@ -0,0 +1,86 @@
+(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
new file mode 100644
index 000000000..b2104cb1b
--- /dev/null
+++ b/luxc/src/lux/compiler/js/rt.clj
@@ -0,0 +1,1058 @@
+(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 "}")
+ "}"
+ "else if(wantedTag > sum[0]) {" recursion-test "}"
+ "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);"
+ "})")
+ "encodeI64" (str "(function LuxRT$encodeI64(input) {"
+ ;; If input = 0
+ (str "if((input.H === 0) && (input.L === 0)) {"
+ "return '0';"
+ "}")
+ ;; If input < 0
+ (str "if(input.H < 0) {"
+ (str "if(LuxRT$eqI64(input,LuxRT$MIN_VALUE_I64)) {"
+ "var radix = LuxRT$makeI64(0,10);"
+ "var div = LuxRT$divI64(input,radix);"
+ "var rem = LuxRT$subI64(LuxRT$mulI64(div,radix),input);"
+ "return LuxRT$encodeI64(div).concat(rem.L+'');"
+ "}")
+ (str "else {"
+ "return '-'.concat(LuxRT$encodeI64(LuxRT$negateI64(input)));"
+ "}")
+ "}")
+ ;; If input > 0
+ (str "var chunker = LuxRT$makeI64(0,1000000);"
+ "var rem = input;"
+ "var result = '';"
+ "while(true) {"
+ (str "var remDiv = LuxRT$divI64(rem,chunker);"
+ "var chunk = LuxRT$subI64(rem,LuxRT$mulI64(remDiv,chunker));"
+ "var digits = (chunk.L >>> 0)+'';"
+ "rem = remDiv;"
+ (str "if((rem.H === 0) && (rem.L === 0)) {"
+ "return digits.concat(result);"
+ "}"
+ "else {"
+ (str "while(digits.length < 6) {"
+ "digits = '0' + digits;"
+ "}")
+ "result = '' + digits + result;"
+ "}"))
+ "}")
+ "})")
+ "decodeI64" (str "(function LuxRT$decodeI64(input) {"
+ "input = LuxRT$clean_separators(input);"
+ (str "if(/^-?\\d+$/.exec(input)) {"
+ (str "var isNegative = (input.charAt(0) == '-');"
+ "var sign = isNegative ? -1 : 1;"
+ "input = isNegative ? input.substring(1) : input;"
+
+ "var chunkPower = LuxRT$fromNumberI64(Math.pow(10, 8));"
+ "var result = LuxRT$ZERO;"
+ (str "for (var i = 0; i < input.length; i += 8) {"
+ "var size = Math.min(8, input.length - i);"
+ "var value = parseInt(input.substring(i, i + size), 10);"
+ (str "if (size < 8) {"
+ "var power = LuxRT$fromNumberI64(Math.pow(10, size));"
+ "result = LuxRT$addI64(LuxRT$mulI64(result,power),LuxRT$fromNumberI64(value));"
+ "}"
+ "else {"
+ "result = LuxRT$addI64(LuxRT$mulI64(result,chunkPower),LuxRT$fromNumberI64(value));"
+ "}")
+ "}")
+ "result = LuxRT$mulI64(result,LuxRT$fromNumberI64(sign));"
+ (str "return " (make-some "result") ";")
+ )
+ "}"
+ "else {"
+ (str "return " const-none ";")
+ "}")
+ "})")
+ })
+
+(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)];"
+ "})")
+ "encodeN64" (str "(function LuxRT$encodeN64(input) {"
+ (str "if(input.H < 0) {"
+ ;; Too big
+ "var lastDigit = LuxRT$remI64(input, LuxRT$makeI64(0,10));"
+ "var minusLastDigit = LuxRT$divI64(input, LuxRT$makeI64(0,10));"
+ "return '+'.concat(LuxRT$encodeI64(minusLastDigit)).concat(LuxRT$encodeI64(lastDigit));"
+ "}"
+ "else {"
+ ;; Small enough
+ "return '+'.concat(LuxRT$encodeI64(input));"
+ "}")
+ "})")
+ "decodeN64" (str "(function LuxRT$decodeN64(input) {"
+ "input = LuxRT$clean_separators(input);"
+ (str "if(/^\\+\\d+$/.exec(input)) {"
+ (str "input = input.substring(1);")
+ (str "if(input.length <= 18) {"
+ ;; Short enough...
+ "return LuxRT$decodeI64(input);"
+ "}"
+ "else {"
+ ;; Too long
+ (str "var prefix = LuxRT$decodeI64(input.substring(0, input.length-1))[2];"
+ "var suffix = LuxRT$decodeI64(input.charAt(input.length-1))[2];"
+ "var total = LuxRT$addI64(LuxRT$mulI64(prefix,LuxRT$fromNumberI64(10)),suffix);"
+ (str "if(LuxRT$ltN64(total,prefix)) {"
+ (str "return " const-none ";")
+ "}"
+ "else {"
+ (str "return " (make-some "total") ";")
+ "}"))
+ "}")
+ "}"
+ "else {"
+ (str "return " const-none ";")
+ "}")
+ "})")
+ "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);"
+ "})")
+ "divD64" (str "(function LuxRT$divD64(l,r) {"
+ "return LuxRT$shlI64(LuxRT$divI64(l,LuxRT$fromNumberI64(r.H)),32);"
+ "})")
+ "degToReal" (str "(function LuxRT$degToReal(input) {"
+ "var two32 = Math.pow(2,32);"
+ "var high = input.H / two32;"
+ "var low = (input.L / two32) / two32;"
+ "return high+low;"
+ "})")
+ "realToDeg" (str "(function LuxRT$realToDeg(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);"
+ "})")
+ "_add_deg_digit_powers" (str "(function LuxRT$_add_deg_digit_powers(left,right) {"
+ "var output = new Array(64);"
+ "var carry = 0;"
+ (str "for(var idx = 63; idx >= 0; idx--) {"
+ "var raw = left[idx] + right[idx] + carry;"
+ "output[idx] = raw % 10;"
+ "raw = (raw / 10)|0;"
+ "}")
+ "return output;"
+ "})")
+ "_times5" (str "(function LuxRT$_times5(exp,digits) {"
+ "var carry = 0;"
+ (str "for(var idx = exp; idx >= 0; idx--) {"
+ "var raw = (digits[exp] * 5) + carry;"
+ "digits[exp] = raw % 10;"
+ "carry = (raw / 10)|0;"
+ "}")
+ "return digits;"
+ "})")
+ "_deg_digit_power" (str "(function LuxRT$_deg_digit_power(exp) {"
+ "var digits = new Array(64);"
+ "digits[exp] = 1;"
+ (str "for(var idx = exp; idx >= 0; idx--) {"
+ "digits = LuxRT$_times5(exp,digits);"
+ "}")
+ "return digits;"
+ "})")
+ "_bitIsSet" (str "(function LuxRT$_bitIsSet(input,idx) {"
+ "idx &= 63;"
+ (str "if(idx < 32) {"
+ "return (input.L & (1 << idx)) !== 0;"
+ "}")
+ (str "else {"
+ "return (input.H & (1 << (idx - 32))) !== 0;"
+ "}")
+ "})")
+ "encodeD64" (str "(function LuxRT$encodeD64(input) {"
+ (str "if(LuxRT$eqI64(input,LuxRT$ZERO)) {"
+ "return '.0';"
+ "}")
+ "var digits = new Array(64);"
+ (str "for(var idx = 63; idx >= 0; idx--) {"
+ (str "if(LuxRT$_bitIsSet(input,idx)) {"
+ "var power = LuxRT$_deg_digit_power(63 - idx);"
+ "digits = LuxRT$_add_deg_digit_powers(digits,power);"
+ "}")
+ "}")
+ "var raw = '.'.concat(digits.join(''));"
+ "return raw.split(/0*$/)[0];"
+ "})")
+ "deg_text_to_digits" (str "(function LuxRT$deg_text_to_digits(input) {"
+ "var output = new Array(64);"
+ (str "for(var idx = input.length-1; idx >= 0; idx--) {"
+ "output[idx] = parseInt(input.substring(idx, idx+1));"
+ "}")
+ "return output;"
+ "})")
+ "deg_digits_lt" (str "(function LuxRT$deg_digits_lt(l,r) {"
+ (str "for(var idx = 0; idx < 64; idx++) {"
+ (str "if(l[idx] < r[idx]) {"
+ "return true;"
+ "}"
+ "else if(l[idx] > r[idx]) {"
+ "return false;"
+ "}")
+ "}")
+ "return false;"
+ "})")
+ "deg_digits_sub_once" (str "(function LuxRT$deg_digits_sub_once(target,digit,idx) {"
+ (str "while(true) {"
+ (str "if(target[idx] > digit) {"
+ (str "target[idx] = target[idx] - digit;"
+ "return target;")
+ "}"
+ "else {"
+ (str "target[idx] = 10 - (digit - target[idx]);"
+ "idx--;"
+ "digit=1;")
+ "}")
+ "}")
+ "})")
+ "deg_digits_sub" (str "(function LuxRT$deg_digits_sub(l,r) {"
+ (str "for(var idx = 63; idx >= 0; idx--) {"
+ "l = LuxRT$deg_digits_sub_once(l,r[idx],idx);"
+ "}")
+ "return l;"
+ "})")
+ "decodeD64" (let [failure (str "return " const-none ";")]
+ (str "(function LuxRT$decodeD64(input) {"
+ "input = LuxRT$clean_separators(input);"
+ (str "if(/^\\.\\d+$/.exec(input) && input.length <= 65) {"
+ (str "try {"
+ (str "var digits = LuxRT$deg_text_to_digits(input.substring(1));")
+ "var output = LuxRT$makeI64(0,0);"
+ (str "for(var idx = 0; idx < 64; idx++) {"
+ "var power = LuxRT$deg_text_to_digits(idx);"
+ (str "if(LuxRT$deg_digits_lt(power,digits)) {"
+ (str "digits = LuxRT$deg_digits_sub(digits,power);"
+ "var powerBit = LuxRT$shlI64(LuxRT$makeI64(0,1),(63-idx));"
+ "output = LuxRT$orI64(output,powerBit);")
+ "}")
+ "}")
+ (str "return " (make-some "output") ";")
+ "}"
+ "catch(ex) {"
+ failure
+ "}")
+ "}"
+ "else {"
+ failure
+ "}")
+ "})"))
+ })
+
+(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"))
+ ""))))
diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj
new file mode 100644
index 000000000..6c4731e16
--- /dev/null
+++ b/luxc/src/lux/compiler/jvm.clj
@@ -0,0 +1,263 @@
+(ns lux.compiler.jvm
+ (: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]
+ [host :as &host])
+ [lux.host.generics :as &host-generics]
+ [lux.optimizer :as &o]
+ [lux.analyser.base :as &a]
+ [lux.analyser.module :as &a-module]
+ (lux.compiler [core :as &&core]
+ [io :as &&io]
+ [cache :as &&cache]
+ [parallel :as &&parallel])
+ (lux.compiler.jvm [base :as &&]
+ [lux :as &&lux]
+ [case :as &&case]
+ [lambda :as &&lambda]
+ [rt :as &&rt]
+ [cache :as &&jvm-cache])
+ (lux.compiler.jvm.proc [common :as &&proc-common]
+ [host :as &&proc-host]))
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor)))
+
+;; [Resources]
+(def ^:private !source->last-line (atom nil))
+
+(defn ^:private compile-expression [$begin syntax]
+ (|let [[[?type [_file-name _line _]] ?form] syntax]
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [debug-label (new Label)
+ _ (when (not= _line (get @!source->last-line _file-name))
+ (doto *writer*
+ (.visitLabel debug-label)
+ (.visitLineNumber (int _line) debug-label))
+ (swap! !source->last-line assoc _file-name _line))]]
+ (|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/$real ?value)
+ (&&lux/compile-real ?value)
+
+ (&o/$char ?value)
+ (&&lux/compile-char ?value)
+
+ (&o/$text ?value)
+ (&&lux/compile-text ?value)
+
+ (&o/$tuple ?elems)
+ (&&lux/compile-tuple (partial compile-expression $begin) ?elems)
+
+ (&o/$var (&/$Local ?idx))
+ (&&lux/compile-local (partial compile-expression $begin) ?idx)
+
+ (&o/$captured ?scope ?captured-id ?source)
+ (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source)
+
+ (&o/$var (&/$Global ?owner-class ?name))
+ (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name)
+
+ (&o/$apply ?fn ?args)
+ (&&lux/compile-apply (partial compile-expression $begin) ?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 (partial compile-expression $begin) $begin _register-offset ?args)
+
+ (&o/$variant ?tag ?tail ?members)
+ (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members)
+
+ (&o/$case ?value [?pm ?bodies])
+ (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies)
+
+ (&o/$let _value _register _body)
+ (&&lux/compile-let (partial compile-expression $begin) _value _register _body)
+
+ (&o/$record-get _value _path)
+ (&&lux/compile-record-get (partial compile-expression $begin) _value _path)
+
+ (&o/$if _test _then _else)
+ (&&lux/compile-if (partial compile-expression $begin) _test _then _else)
+
+ (&o/$function _register-offset ?arity ?scope ?env ?body)
+ (&&lambda/compile-function compile-expression &/$None ?arity ?scope ?env ?body)
+
+ (&o/$ann ?value-ex ?type-ex)
+ (compile-expression $begin ?value-ex)
+
+ (&o/$proc [?proc-category ?proc-name] ?args special-args)
+ (if (= "jvm" ?proc-category)
+ (&&proc-host/compile-proc (partial compile-expression $begin) ?proc-name ?args special-args)
+ (&&proc-common/compile-proc (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args))
+
+ _
+ (assert false (prn-str 'compile-expression (&/adt->text syntax)))
+ ))
+ ))
+
+(defn init!
+ "(-> (List Text) Null)"
+ [resources-dirs ^String target-dir]
+ (do (reset! !source->last-line {})
+ (let [class-loader (ClassLoader/getSystemClassLoader)
+ addURL (doto (.getDeclaredMethod java.net.URLClassLoader "addURL" (into-array [java.net.URL]))
+ (.setAccessible true))]
+ (doseq [^String resources-dir (&/->seq resources-dirs)]
+ (.invoke addURL class-loader
+ (to-array [(->> resources-dir (new java.io.File) .toURI .toURL)]))))))
+
+(defn eval! [expr]
+ (&/with-eval
+ (|do [module &/get-module-name
+ id &/gen-id
+ [file-name _ _] &/cursor
+ :let [class-name (str (&host/->module-class module) "/" id)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ class-name nil "java/lang/Object" nil)
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/value-field "Ljava/lang/Object;" nil nil)
+ (doto (.visitEnd)))
+ (.visitSource file-name nil))]
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [_ (.visitCode *writer*)]
+ _ (compile-expression nil expr)
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/PUTSTATIC class-name &/value-field "Ljava/lang/Object;")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ :let [bytecode (.toByteArray (doto =class
+ .visitEnd))]
+ _ (&&/save-class! (str id) bytecode)
+ loader &/loader]
+ (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id))
+ (.getField &/value-field)
+ (.get nil)
+ return))))
+
+(def all-compilers
+ (let [compile-expression* (partial compile-expression nil)]
+ (&/T [(partial &&lux/compile-def compile-expression)
+ (partial &&lux/compile-program compile-expression*)
+ (fn [macro args state] (-> macro (.apply args) (.apply state)))
+ (partial &&proc-host/compile-jvm-class compile-expression*)
+ &&proc-host/compile-jvm-interface])))
+
+(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)
+ +datum-sig+ "Ljava/lang/Object;"]
+ (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 (&&cache/load name)
+ (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 "[Compiler Error] Can't re-define a module!")
+ (|do [_ (&&cache/delete name)
+ _ (&a-module/create-module name file-hash)
+ _ (&a-module/flag-active-module name)
+ :let [module-class-name (str (&host/->module-class name) "/_")
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ module-class-name nil "java/lang/Object" nil)
+ (.visitSource file-name nil))]
+ _ (if (= "lux" name)
+ (|do [_ &&rt/compile-Function-class
+ _ &&rt/compile-LuxRT-class
+ _ &&rt/compile-LuxRunnable-class]
+ (return nil))
+ (return nil))]
+ (fn [state]
+ (|case ((&/with-writer =class
+ (&/exhaust% compiler-step))
+ (&/set$ &/$source (&reader/from name file-content) state))
+ (&/$Right ?state _)
+ (&/run-state (|do [:let [_ (.visitEnd =class)]
+ _ (&a-module/flag-compiled-module name)
+ _ (&&/save-class! &/module-class-name (.toByteArray =class))
+ module-descriptor (&&core/generate-module-descriptor file-hash)
+ _ (&&core/write-module-descriptor! name module-descriptor)]
+ (return file-hash))
+ ?state)
+
+ (&/$Left ?message)
+ (&/fail* ?message))))))))
+ )
+ ))
+
+(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String
+ (class (byte-array []))
+ Integer/TYPE
+ Integer/TYPE]))
+ (.setAccessible true))]
+ (defn memory-class-loader [store]
+ (proxy [java.lang.ClassLoader]
+ []
+ (findClass [^String class-name]
+ (if-let [^bytes bytecode (get @store class-name)]
+ (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))]))
+ (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))
+
+(defn jvm-host []
+ (let [store (atom {})]
+ (&/$Jvm (&/T [;; "lux;writer"
+ &/$None
+ ;; "lux;loader"
+ (memory-class-loader store)
+ ;; "lux;classes"
+ store
+ ;; "lux;module-states"
+ (&/|table)
+ ;; lux;type-env
+ (&/|table)
+ ;; lux;dummy-mappings
+ (&/|table)
+ ]))))
+
+(let [!err! *err*]
+ (defn compile-program [mode program-module resources-dir source-dirs target-dir]
+ (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs
+ &&jvm-cache/load-def-value
+ &&jvm-cache/install-all-defs-in-module
+ &&jvm-cache/uninstall-all-defs-in-module)
+ _ (compile-module source-dirs "lux")]
+ (compile-module source-dirs program-module))]
+ (|case (m-action (&/init-state mode (jvm-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/base.clj b/luxc/src/lux/compiler/jvm/base.clj
index e57fc1e2b..99e0f08e9 100644
--- a/luxc/src/lux/compiler/base.clj
+++ b/luxc/src/lux/compiler/jvm/base.clj
@@ -1,4 +1,4 @@
-(ns lux.compiler.base
+(ns lux.compiler.jvm.base
(:require (clojure [template :refer [do-template]]
[string :as string])
[clojure.java.io :as io]
@@ -9,7 +9,8 @@
[host :as &host])
(lux.analyser [base :as &a]
[module :as &a-module])
- [lux.host.generics :as &host-generics])
+ [lux.host.generics :as &host-generics]
+ [lux.compiler.core :as &&])
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -20,8 +21,6 @@
(java.lang.reflect Field)))
;; [Constants]
-(def !output-dir (atom nil))
-
(def ^:const ^String function-class "lux/Function")
(def ^:const ^String lux-utils-class "lux/LuxRT")
(def ^:const ^String unit-tag-field "unit_tag")
@@ -37,33 +36,22 @@
(def ^:const arity-field "_arity_")
(def ^:const partials-field "_partials_")
-(def ^:const section-separator (->> 29 char str))
-(def ^:const datum-separator (->> 31 char str))
-(def ^:const entry-separator (->> 30 char str))
-
;; [Utils]
-(defn ^:private write-file [^String file-name ^bytes data]
- (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name))
- (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))]
- (.write stream data)
- (.flush stream))))
-
(defn ^:private write-output [module name data]
(let [^String module* (&host/->module-class module)
- module-dir (str @!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))]
+ module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))]
(.mkdirs (File. module-dir))
- (write-file (str module-dir java.io.File/separator name ".class") data)))
+ (&&/write-file (str module-dir java.io.File/separator name ".class") data)))
(defn class-exists? [^String module ^String class-name]
"(-> Text Text (IO Bool))"
(|do [_ (return nil)
- :let [full-path (str @!output-dir java.io.File/separator module java.io.File/separator class-name ".class")
+ :let [full-path (str @&&/!output-dir java.io.File/separator module java.io.File/separator class-name ".class")
exists? (.exists (File. full-path))]]
(return exists?)))
;; [Exports]
(defn ^Class load-class! [^ClassLoader loader name]
- ;; (prn 'load-class! name)
(.loadClass loader name))
(defn save-class! [name bytecode]
@@ -75,23 +63,10 @@
_ (swap! !classes assoc real-name bytecode)
_ (when (not eval?)
(write-output module name bytecode))
- _ (load-class! loader real-name)]]
- (return nil)))
-
-(def ^String lux-module-descriptor-name "lux_module_descriptor")
-
-(defn write-module-descriptor! [^String name ^String descriptor]
- (|do [_ (return nil)
- :let [lmd-dir (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator))
- _ (.mkdirs (File. lmd-dir))
- _ (write-file (str lmd-dir java.io.File/separator lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]]
+ ;; _ (load-class! loader real-name)
+ ]]
(return nil)))
-(defn read-module-descriptor! [^String name]
- (|do [_ (return nil)]
- (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name)
- :encoding "UTF-8"))))
-
(do-template [<wrap-name> <unwrap-name> <class> <unwrap-method> <prim> <dup>]
(do (defn <wrap-name> [^MethodVisitor writer]
(doto writer
diff --git a/luxc/src/lux/compiler/jvm/cache.clj b/luxc/src/lux/compiler/jvm/cache.clj
new file mode 100644
index 000000000..a42c7afdd
--- /dev/null
+++ b/luxc/src/lux/compiler/jvm/cache.clj
@@ -0,0 +1,64 @@
+(ns lux.compiler.jvm.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.jvm [base :as &&]))
+ (:import (java.io File)
+ (java.lang.reflect Field)
+ ))
+
+;; [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)))
+
+(defn ^:private get-field [^String field-name ^Class class]
+ "(-> Text Class Object)"
+ (-> class ^Field (.getField field-name) (.get nil)))
+
+;; [Resources]
+(defn load-def-value [module name]
+ (|do [loader &/loader
+ :let [def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name name)))]]
+ (return (get-field &/value-field def-class))))
+
+(defn install-all-defs-in-module [module-name]
+ (|do [!classes &/classes
+ :let [module-path (str @&&core/!output-dir java.io.File/separator module-name)
+ file-name+content (for [^File file (seq (.listFiles (new File module-path)))
+ :when (not (.isDirectory file))
+ :let [file-name (.getName file)]]
+ [(second (re-find #"^(.*)\.class$" file-name))
+ (read-file file)])
+ _ (doseq [[file-name content] file-name+content]
+ (swap! !classes assoc (str (&host-generics/->class-name module-name)
+ "."
+ file-name)
+ content))]]
+ (return (map first file-name+content))))
+
+(defn uninstall-all-defs-in-module [module-name]
+ (|do [!classes &/classes
+ :let [module-path (str @&&core/!output-dir java.io.File/separator module-name)
+ installed-files (for [^File file (seq (.listFiles (new File module-path)))
+ :when (not (.isDirectory file))
+ :let [file-name (.getName file)]]
+ (second (re-find #"^(.*)\.class$" file-name)))
+ _ (swap! !classes (fn [_classes-dict]
+ (reduce dissoc _classes-dict installed-files)))]]
+ (return nil)))
diff --git a/luxc/src/lux/compiler/case.clj b/luxc/src/lux/compiler/jvm/case.clj
index aac3b6c98..da8d8d0a9 100644
--- a/luxc/src/lux/compiler/case.clj
+++ b/luxc/src/lux/compiler/jvm/case.clj
@@ -1,4 +1,4 @@
-(ns lux.compiler.case
+(ns lux.compiler.jvm.case
(:require (clojure [set :as set]
[template :refer [do-template]])
clojure.core.match
@@ -11,7 +11,7 @@
[host :as &host]
[optimizer :as &o])
[lux.analyser.case :as &a-case]
- [lux.compiler.base :as &&])
+ [lux.compiler.jvm.base :as &&])
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
diff --git a/luxc/src/lux/compiler/lambda.clj b/luxc/src/lux/compiler/jvm/lambda.clj
index 006476bef..87d977012 100644
--- a/luxc/src/lux/compiler/lambda.clj
+++ b/luxc/src/lux/compiler/jvm/lambda.clj
@@ -1,4 +1,4 @@
-(ns lux.compiler.lambda
+(ns lux.compiler.jvm.lambda
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
@@ -13,7 +13,7 @@
[optimizer :as &o])
[lux.host.generics :as &host-generics]
[lux.analyser.base :as &a]
- (lux.compiler [base :as &&]))
+ (lux.compiler.jvm [base :as &&]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
diff --git a/luxc/src/lux/compiler/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj
index 36d923e60..12a2f83c7 100644
--- a/luxc/src/lux/compiler/lux.clj
+++ b/luxc/src/lux/compiler/jvm/lux.clj
@@ -1,4 +1,4 @@
-(ns lux.compiler.lux
+(ns lux.compiler.jvm.lux
(:require (clojure [string :as string]
[set :as set]
[template :refer [do-template]])
@@ -15,8 +15,8 @@
(lux.analyser [base :as &a]
[module :as &a-module]
[meta :as &a-meta])
- (lux.compiler [base :as &&]
- [lambda :as &&lambda]))
+ (lux.compiler.jvm [base :as &&]
+ [lambda :as &&lambda]))
(:import (org.objectweb.asm Opcodes
Label
ClassWriter
@@ -276,16 +276,13 @@
(|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope
false
(de-ann ?body))]
- (|do [:let [=value-type (&a/expr-type* ?body)]
- [file-name _ _] &/cursor
+ (|do [[file-name _ _] &/cursor
:let [datum-sig "Ljava/lang/Object;"
def-name (&host/def-name ?name)
current-class (str (&host/->module-class module-name) "/" def-name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version class-flags
current-class nil &&/function-class (into-array String []))
- (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
- (doto (.visitEnd)))
(-> (.visitField field-flags &/value-field datum-sig nil nil)
(doto (.visitEnd)))
(.visitSource file-name nil))]
@@ -347,16 +344,13 @@
(return nil)))
_
- (|do [:let [=value-type (&a/expr-type* ?body)]
- [file-name _ _] &/cursor
+ (|do [[file-name _ _] &/cursor
:let [datum-sig "Ljava/lang/Object;"
def-name (&host/def-name ?name)
current-class (str (&host/->module-class module-name) "/" def-name)
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit &host/bytecode-version class-flags
current-class nil "java/lang/Object" (into-array String []))
- (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
- (doto (.visitEnd)))
(-> (.visitField field-flags &/value-field datum-sig nil nil)
(doto (.visitEnd)))
(.visitSource file-name nil))]
diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj
new file mode 100644
index 000000000..ffb621c3b
--- /dev/null
+++ b/luxc/src/lux/compiler/jvm/proc/common.clj
@@ -0,0 +1,1057 @@
+(ns lux.compiler.jvm.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]
+ [lexer :as &lexer]
+ [parser :as &parser]
+ [analyser :as &analyser]
+ [optimizer :as &o]
+ [host :as &host])
+ [lux.type.host :as &host-type]
+ [lux.host.generics :as &host-generics]
+ [lux.analyser.base :as &a]
+ [lux.compiler.jvm.base :as &&])
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor
+ AnnotationVisitor)))
+
+;; [Resources]
+(defn ^:private compile-array-new [compile ?values special-args]
+ (|do [:let [(&/$Cons ?length (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?length)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY "java/lang/Object")]]
+ (return nil)))
+
+(defn ^:private compile-array-get [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ array-type (&host/->java-sig (&a/expr-type* ?array))
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]
+ :let [$is-null (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitJumpInsn Opcodes/IFNULL $is-null)
+ (.visitLdcInsn (int 1))
+ (.visitLdcInsn "")
+ (.visitInsn Opcodes/DUP2_X1) ;; I?2I?
+ (.visitInsn Opcodes/POP2) ;; I?2
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $is-null)
+ (.visitInsn Opcodes/POP)
+ (.visitLdcInsn (int 0))
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitLdcInsn &/unit-tag)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitLabel $end))]]
+ (return nil)))
+
+(defn ^:private compile-array-put [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ _ (compile ?elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return nil)))
+
+(defn ^:private compile-array-remove [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitInsn Opcodes/AASTORE))]]
+ (return nil)))
+
+(defn ^:private compile-array-size [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Nil)) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARRAYLENGTH)
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
+ (return nil)))
+
+(do-template [<name> <op>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (&&/unwrap-long *writer*)]
+ _ (compile ?mask)
+ :let [_ (&&/unwrap-long *writer*)]
+ :let [_ (doto *writer*
+ (.visitInsn <op>)
+ &&/wrap-long)]]
+ (return nil)))
+
+ ^:private compile-bit-and Opcodes/LAND
+ ^:private compile-bit-or Opcodes/LOR
+ ^:private compile-bit-xor Opcodes/LXOR
+ )
+
+(defn ^:private compile-bit-count [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (&&/unwrap-long *writer*)]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "bitCount" "(J)I")
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
+ (return nil)))
+
+(do-template [<name> <op>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Cons ?shift (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (&&/unwrap-long *writer*)]
+ _ (compile ?shift)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitInsn <op>)
+ &&/wrap-long)]]
+ (return nil)))
+
+ ^:private compile-bit-shift-left Opcodes/LSHL
+ ^:private compile-bit-shift-right Opcodes/LSHR
+ ^:private compile-bit-unsigned-shift-right Opcodes/LUSHR
+ )
+
+(defn ^:private compile-lux-is [compile ?values special-args]
+ (|do [:let [(&/$Cons ?left (&/$Cons ?right (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?left)
+ _ (compile ?right)
+ :let [$then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitJumpInsn Opcodes/IF_ACMPEQ $then)
+ ;; else
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;")
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;")
+ (.visitLabel $end))]]
+ (return nil)))
+
+(defn ^:private compile-lux-try [compile ?values special-args]
+ (|do [:let [(&/$Cons ?op (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?op)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "lux/Function")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "runTry" "(Llux/Function;)[Ljava/lang/Object;"))]]
+ (return nil)))
+
+(do-template [<name> <opcode> <unwrap> <wrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap>)
+ _ (doto *writer*
+ (.visitInsn <opcode>)
+ <wrap>)]]
+ (return nil)))
+
+ ^:private compile-int-add Opcodes/LADD &&/unwrap-long &&/wrap-long
+ ^:private compile-int-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long
+ ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long
+ ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long
+ ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long
+
+ ^:private compile-nat-add Opcodes/LADD &&/unwrap-long &&/wrap-long
+ ^:private compile-nat-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long
+ ^:private compile-nat-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long
+
+ ^:private compile-deg-add Opcodes/LADD &&/unwrap-long &&/wrap-long
+ ^:private compile-deg-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long
+ ^:private compile-deg-rem Opcodes/LSUB &&/unwrap-long &&/wrap-long
+ ^:private compile-deg-scale Opcodes/LMUL &&/unwrap-long &&/wrap-long
+
+ ^:private compile-real-add Opcodes/DADD &&/unwrap-double &&/wrap-double
+ ^:private compile-real-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double
+ ^:private compile-real-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double
+ ^:private compile-real-div Opcodes/DDIV &&/unwrap-double &&/wrap-double
+ ^:private compile-real-rem Opcodes/DREM &&/unwrap-double &&/wrap-double
+ )
+
+(do-template [<name> <comp-method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-long)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ &&/unwrap-long)
+ _ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <comp-method> "(JJ)J")
+ (&&/wrap-long))]]
+ (return nil)))
+
+ ^:private compile-nat-div "div_nat"
+ ^:private compile-nat-rem "rem_nat"
+ )
+
+(do-template [<name> <cmpcode> <cmp-output> <unwrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap>)
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitInsn <cmpcode>)
+ (.visitLdcInsn (int <cmp-output>))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-int-eq Opcodes/LCMP 0 &&/unwrap-long
+ ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long
+
+ ^:private compile-real-eq Opcodes/DCMPG 0 &&/unwrap-double
+ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double
+ )
+
+(do-template [<name> <opcode> <unwrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap>)
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitJumpInsn <opcode> $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-char-eq Opcodes/IF_ICMPEQ &&/unwrap-char
+ ^:private compile-char-lt Opcodes/IF_ICMPLT &&/unwrap-char
+ )
+
+(defn ^:private compile-real-hash [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ &&/unwrap-double
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "doubleToRawLongBits" "(D)J")
+ &&/wrap-long)]]
+ (return nil)))
+
+(do-template [<name> <cmp-output>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-long)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ &&/unwrap-long)
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
+ (.visitLdcInsn (int <cmp-output>))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-nat-eq 0
+
+ ^:private compile-deg-eq 0
+ ^:private compile-deg-lt -1
+ )
+
+(defn ^:private compile-nat-lt [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-long)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ &&/unwrap-long)
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
+ (.visitLdcInsn (int -1))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+(do-template [<name> <instr> <wrapper>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ <instr>
+ <wrapper>)]]
+ (return nil)))
+
+ ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long
+ ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long
+
+ ^:private compile-int-min-value (.visitLdcInsn Long/MIN_VALUE) &&/wrap-long
+ ^:private compile-int-max-value (.visitLdcInsn Long/MAX_VALUE) &&/wrap-long
+
+ ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long
+ ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long
+
+ ^:private compile-real-min-value (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double
+ ^:private compile-real-max-value (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double
+
+ ^:private compile-real-not-a-number (.visitLdcInsn Double/NaN) &&/wrap-double
+ ^:private compile-real-positive-infinity (.visitLdcInsn Double/POSITIVE_INFINITY) &&/wrap-double
+ ^:private compile-real-negative-infinity (.visitLdcInsn Double/NEGATIVE_INFINITY) &&/wrap-double
+ )
+
+(do-template [<encode-name> <encode-method> <decode-name> <decode-method>]
+ (do (defn <encode-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <encode-method> "(J)Ljava/lang/String;"))]]
+ (return nil)))
+
+ (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")]
+ (defn <decode-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <decode-method> "(Ljava/lang/String;)Ljava/lang/Object;"))]]
+ (return nil)))))
+
+ ^:private compile-nat-encode "encode_nat" ^:private compile-nat-decode "decode_nat"
+ ^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg"
+ )
+
+(do-template [<name> <class> <signature> <unwrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ <unwrap>
+ (.visitMethodInsn Opcodes/INVOKESTATIC <class> "toString" <signature>))]]
+ (return nil)))
+
+ ^:private compile-int-encode "java/lang/Long" "(J)Ljava/lang/String;" &&/unwrap-long
+ ^:private compile-real-encode "java/lang/Double" "(D)Ljava/lang/String;" &&/unwrap-double
+ )
+
+
+(do-template [<name> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(Ljava/lang/String;)[Ljava/lang/Object;"))]]
+ (return nil)))
+
+ ^:private compile-int-decode "decode_int"
+ ^:private compile-real-decode "decode_real"
+ )
+
+(do-template [<name> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-long)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ &&/unwrap-long)]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(JJ)J")
+ &&/wrap-long)]]
+ (return nil)))
+
+ ^:private compile-deg-mul "mul_deg"
+ ^:private compile-deg-div "div_deg"
+ )
+
+(do-template [<name> <class> <method> <sig> <unwrap> <wrap>]
+ (let [+wrapper-class+ (&host-generics/->bytecode-class-name <class>)]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> <sig>)
+ <wrap>)]]
+ (return nil))))
+
+ ^:private compile-deg-to-real "java.lang.Long" "deg-to-real" "(J)D" &&/unwrap-long &&/wrap-double
+ ^:private compile-real-to-deg "java.lang.Double" "real-to-deg" "(D)J" &&/unwrap-double &&/wrap-long
+ )
+
+(let [widen (fn [^MethodVisitor *writer*]
+ (doto *writer*
+ (.visitInsn Opcodes/I2L)))
+ shrink (fn [^MethodVisitor *writer*]
+ (doto *writer*
+ (.visitInsn Opcodes/L2I)
+ (.visitInsn Opcodes/I2C)))]
+ (do-template [<name> <unwrap> <wrap> <adjust>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>
+ <adjust>
+ <wrap>)]]
+ (return nil)))
+
+ ^:private compile-nat-to-char &&/unwrap-long &&/wrap-char shrink
+ ^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen
+ ))
+
+(defn ^:private compile-char-to-text [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;"))]]
+ (return nil)))
+
+(do-template [<name>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)]
+ (return nil)))
+
+ ^:private compile-nat-to-int
+ ^:private compile-int-to-nat
+ )
+
+(do-template [<name> <unwrap> <op> <wrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ <unwrap>
+ (.visitInsn <op>)
+ <wrap>)]]
+ (return nil)))
+
+ ^:private compile-real-to-int &&/unwrap-double Opcodes/D2L &&/wrap-long
+ ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double
+ )
+
+(defn ^:private compile-text-eq [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
+ (&&/wrap-boolean))]]
+ (return nil)))
+
+(defn ^:private compile-text-lt [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ :let [$then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I")
+ (.visitLdcInsn (int -1))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+(defn compile-text-append [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]]
+ (return nil)))
+
+(defn compile-text-clip [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?from)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ _ (compile ?to)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;"))]]
+ (return nil)))
+
+(do-template [<name> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?part)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?start)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" <method> "(Ljava/lang/String;I)I"))]
+ :let [$not-found (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int -1))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found)
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $not-found)
+ (.visitInsn Opcodes/POP)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-text-index "indexOf"
+ ^:private compile-text-last-index "lastIndexOf"
+ )
+
+(do-template [<name> <class> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> "()I")
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
+ (return nil)))
+
+ ^:private compile-text-size "java/lang/String" "length"
+ ^:private compile-text-hash "java/lang/Object" "hashCode"
+ )
+
+(defn ^:private compile-text-replace-all [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?pattern)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?replacement)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]]
+ (return nil)))
+
+(defn ^:private compile-text-contains? [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Cons ?sub (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?sub)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "contains" "(Ljava/lang/CharSequence;)Z")
+ &&/wrap-boolean)]]
+ (return nil)))
+
+(do-template [<name> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" <method> "()Ljava/lang/String;"))]]
+ (return nil)))
+
+ ^:private compile-text-trim "trim"
+ ^:private compile-text-upper-case "toUpperCase"
+ ^:private compile-text-lower-case "toLowerCase"
+ )
+
+(defn ^:private compile-text-char [compile ?values special-args]
+ (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?text)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]]
+ (return nil)))
+
+(defn ^:private compile-io-log [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))]
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/String;)V")
+ (.visitLdcInsn &/unit-tag))]]
+ (return nil)))
+
+(defn ^:private compile-io-error [compile ?values special-args]
+ (|do [:let [(&/$Cons ?message (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW "java/lang/Error")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?message)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Error" "<init>" "(Ljava/lang/String;)V")
+ (.visitInsn Opcodes/ATHROW))]]
+ (return nil)))
+
+(defn ^:private compile-io-exit [compile ?values special-args]
+ (|do [:let [(&/$Cons ?code (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?code)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "exit" "(I)V")
+ (.visitInsn Opcodes/ACONST_NULL))]]
+ (return nil)))
+
+(defn ^:private compile-io-current-time [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "currentTimeMillis" "()J")
+ &&/wrap-long)]]
+ (return nil)))
+
+(do-template [<name> <field>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Math" <field> "D")
+ &&/wrap-double)]]
+ (return nil)))
+
+ ^: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]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ &&/unwrap-double
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" <method> "(D)D")
+ &&/wrap-double)]]
+ (return nil)))
+
+ ^: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-cosh "cosh"
+ ^:private compile-math-sinh "sinh"
+ ^:private compile-math-tanh "tanh"
+ ^:private compile-math-exp "exp"
+ ^:private compile-math-log "log"
+ ^:private compile-math-root2 "sqrt"
+ ^:private compile-math-root3 "cbrt"
+ ^: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]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ &&/unwrap-double)]
+ _ (compile ?param)
+ :let [_ (doto *writer*
+ &&/unwrap-double)]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" <method> "(DD)D")
+ &&/wrap-double)]]
+ (return nil)))
+
+ ^:private compile-math-atan2 "atan2"
+ ^:private compile-math-pow "pow"
+ )
+
+(defn ^:private compile-math-round [compile ?values special-args]
+ (|do [:let [(&/$Cons ?input (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?input)
+ :let [_ (doto *writer*
+ &&/unwrap-double
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "round" "(D)J")
+ (.visitInsn Opcodes/L2D)
+ &&/wrap-double)]]
+ (return nil)))
+
+(defn ^:private compile-atom-new [compile ?values special-args]
+ (|do [:let [(&/$Cons ?init (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW "java/util/concurrent/atomic/AtomicReference")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?init)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/atomic/AtomicReference" "<init>" "(Ljava/lang/Object;)V"))]]
+ (return nil)))
+
+(defn ^:private compile-atom-get [compile ?values special-args]
+ (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?atom)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "get" "()Ljava/lang/Object;"))]]
+ (return nil)))
+
+(defn ^:private compile-atom-compare-and-swap [compile ?values special-args]
+ (|do [:let [(&/$Cons ?atom (&/$Cons ?old (&/$Cons ?new (&/$Nil)))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?atom)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/util/concurrent/atomic/AtomicReference"))]
+ _ (compile ?old)
+ _ (compile ?new)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/atomic/AtomicReference" "compareAndSet" "(Ljava/lang/Object;Ljava/lang/Object;)Z")
+ &&/wrap-boolean)]]
+ (return nil)))
+
+(defn ^:private compile-process-concurrency-level [compile ?values special-args]
+ (|do [:let [(&/$Nil) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "concurrency_level" "I")
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
+ (return nil)))
+
+(defn ^:private compile-process-future [compile ?values special-args]
+ (|do [:let [(&/$Cons ?procedure (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?procedure)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "lux/Function"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "future" "(Llux/Function;)Ljava/lang/Object;"))]]
+ (return nil)))
+
+(defn ^:private compile-process-schedule [compile ?values special-args]
+ (|do [:let [(&/$Cons ?milliseconds (&/$Cons ?procedure (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?milliseconds)
+ :let [_ (doto *writer*
+ &&/unwrap-long)]
+ _ (compile ?procedure)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "lux/Function"))]
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "schedule" "(JLlux/Function;)Ljava/lang/Object;"))]]
+ (return nil)))
+
+(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)
+ "append" (compile-text-append 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)
+ "trim" (compile-text-trim compile ?values special-args)
+ "char" (compile-text-char compile ?values special-args)
+ "upper-case" (compile-text-upper-case compile ?values special-args)
+ "lower-case" (compile-text-lower-case 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)
+ "shift-left" (compile-bit-shift-left compile ?values special-args)
+ "shift-right" (compile-bit-shift-right compile ?values special-args)
+ "unsigned-shift-right" (compile-bit-unsigned-shift-right 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)
+ "encode" (compile-nat-encode compile ?values special-args)
+ "decode" (compile-nat-decode compile ?values special-args)
+ "max-value" (compile-nat-max-value compile ?values special-args)
+ "min-value" (compile-nat-min-value compile ?values special-args)
+ "to-int" (compile-nat-to-int compile ?values special-args)
+ "to-char" (compile-nat-to-char 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)
+ "encode" (compile-deg-encode compile ?values special-args)
+ "decode" (compile-deg-decode compile ?values special-args)
+ "max-value" (compile-deg-max-value compile ?values special-args)
+ "min-value" (compile-deg-min-value compile ?values special-args)
+ "to-real" (compile-deg-to-real compile ?values special-args)
+ "scale" (compile-deg-scale 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-value" (compile-int-max-value compile ?values special-args)
+ "min-value" (compile-int-min-value compile ?values special-args)
+ "to-nat" (compile-int-to-nat compile ?values special-args)
+ "to-real" (compile-int-to-real compile ?values special-args)
+ "encode" (compile-int-encode compile ?values special-args)
+ "decode" (compile-int-decode compile ?values special-args)
+ )
+
+ "real"
+ (case proc
+ "+" (compile-real-add compile ?values special-args)
+ "-" (compile-real-sub compile ?values special-args)
+ "*" (compile-real-mul compile ?values special-args)
+ "/" (compile-real-div compile ?values special-args)
+ "%" (compile-real-rem compile ?values special-args)
+ "=" (compile-real-eq compile ?values special-args)
+ "<" (compile-real-lt compile ?values special-args)
+ "hash" (compile-real-hash compile ?values special-args)
+ "max-value" (compile-real-max-value compile ?values special-args)
+ "min-value" (compile-real-min-value compile ?values special-args)
+ "not-a-number" (compile-real-not-a-number compile ?values special-args)
+ "positive-infinity" (compile-real-positive-infinity compile ?values special-args)
+ "negative-infinity" (compile-real-negative-infinity compile ?values special-args)
+ "to-int" (compile-real-to-int compile ?values special-args)
+ "to-deg" (compile-real-to-deg compile ?values special-args)
+ "encode" (compile-real-encode compile ?values special-args)
+ "decode" (compile-real-decode compile ?values special-args)
+ )
+
+ "char"
+ (case proc
+ "=" (compile-char-eq compile ?values special-args)
+ "<" (compile-char-lt compile ?values special-args)
+ "to-nat" (compile-char-to-nat compile ?values special-args)
+ "to-text" (compile-char-to-text 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)
+ "cosh" (compile-math-cosh compile ?values special-args)
+ "sinh" (compile-math-sinh compile ?values special-args)
+ "tanh" (compile-math-tanh compile ?values special-args)
+ "exp" (compile-math-exp compile ?values special-args)
+ "log" (compile-math-log compile ?values special-args)
+ "root2" (compile-math-root2 compile ?values special-args)
+ "root3" (compile-math-root3 compile ?values special-args)
+ "ceil" (compile-math-ceil compile ?values special-args)
+ "floor" (compile-math-floor compile ?values special-args)
+ "round" (compile-math-round compile ?values special-args)
+ "atan2" (compile-math-atan2 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/jvm/proc/host.clj b/luxc/src/lux/compiler/jvm/proc/host.clj
new file mode 100644
index 000000000..365a26937
--- /dev/null
+++ b/luxc/src/lux/compiler/jvm/proc/host.clj
@@ -0,0 +1,1145 @@
+(ns lux.compiler.jvm.proc.host
+ (: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.type.host :as &host-type]
+ [lux.host.generics :as &host-generics]
+ [lux.analyser.base :as &a]
+ [lux.compiler.jvm.base :as &&])
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor
+ AnnotationVisitor)))
+
+;; [Utils]
+(def init-method "<init>")
+
+(let [class+method+sig {"boolean" &&/unwrap-boolean
+ "byte" &&/unwrap-byte
+ "short" &&/unwrap-short
+ "int" &&/unwrap-int
+ "long" &&/unwrap-long
+ "float" &&/unwrap-float
+ "double" &&/unwrap-double
+ "char" &&/unwrap-char}]
+ (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name]
+ (if-let [unwrap (get class+method+sig class-name)]
+ (doto *writer*
+ unwrap)
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name)))))
+
+(let [boolean-class "java.lang.Boolean"
+ byte-class "java.lang.Byte"
+ short-class "java.lang.Short"
+ int-class "java.lang.Integer"
+ long-class "java.lang.Long"
+ float-class "java.lang.Float"
+ double-class "java.lang.Double"
+ char-class "java.lang.Character"]
+ (defn prepare-return! [^MethodVisitor *writer* *type*]
+ (|case *type*
+ (&/$UnitT)
+ (.visitLdcInsn *writer* &/unit-tag)
+
+ (&/$HostT "boolean" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class)))
+
+ (&/$HostT "byte" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class)))
+
+ (&/$HostT "short" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class)))
+
+ (&/$HostT "int" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class)))
+
+ (&/$HostT "long" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class)))
+
+ (&/$HostT "float" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class)))
+
+ (&/$HostT "double" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class)))
+
+ (&/$HostT "char" (&/$Nil))
+ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class)))
+
+ (&/$HostT _ _)
+ nil
+
+ (&/$NamedT ?name ?type)
+ (prepare-return! *writer* ?type)
+
+ (&/$ExT _)
+ nil
+
+ _
+ (assert false (str 'prepare-return! " " (&type/show-type *type*))))
+ *writer*))
+
+;; [Resources]
+(defn ^:private compile-annotation [writer ann]
+ (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true)
+ (-> (.visit param-name param-value)
+ (->> (|let [[param-name param-value] param])
+ (doseq [param (&/->seq (:params ann))])))
+ (.visitEnd))
+ nil)
+
+(defn ^:private compile-field [^ClassWriter writer field]
+ (|case field
+ (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
+ (|let [=field (.visitField writer
+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL)
+ ?name
+ (&host-generics/gclass->simple-signature ?gclass)
+ (&host-generics/gclass->signature ?gclass) nil)]
+ (do (&/|map (partial compile-annotation =field) ?anns)
+ (.visitEnd =field)
+ nil))
+
+ (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type)
+ (|let [=field (.visitField writer
+ (+ (&host/privacy-modifier->flag =privacy-modifier)
+ (&host/state-modifier->flag =state-modifier))
+ =name
+ (&host-generics/gclass->simple-signature =type)
+ (&host-generics/gclass->signature =type) nil)]
+ (do (&/|map (partial compile-annotation =field) =anns)
+ (.visitEnd =field)
+ nil))
+ ))
+
+(defn ^:private compile-method-return [^MethodVisitor writer output]
+ (|case output
+ (&/$GenericClass "void" (&/$Nil))
+ (.visitInsn writer Opcodes/RETURN)
+
+ (&/$GenericClass "boolean" (&/$Nil))
+ (doto writer
+ &&/unwrap-boolean
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "byte" (&/$Nil))
+ (doto writer
+ &&/unwrap-byte
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "short" (&/$Nil))
+ (doto writer
+ &&/unwrap-short
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "int" (&/$Nil))
+ (doto writer
+ &&/unwrap-int
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass "long" (&/$Nil))
+ (doto writer
+ &&/unwrap-long
+ (.visitInsn Opcodes/LRETURN))
+
+ (&/$GenericClass "float" (&/$Nil))
+ (doto writer
+ &&/unwrap-float
+ (.visitInsn Opcodes/FRETURN))
+
+ (&/$GenericClass "double" (&/$Nil))
+ (doto writer
+ &&/unwrap-double
+ (.visitInsn Opcodes/DRETURN))
+
+ (&/$GenericClass "char" (&/$Nil))
+ (doto writer
+ &&/unwrap-char
+ (.visitInsn Opcodes/IRETURN))
+
+ (&/$GenericClass _class-name (&/$Nil))
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name))
+ (.visitInsn Opcodes/ARETURN))
+
+ _
+ (.visitInsn writer Opcodes/ARETURN)))
+
+(defn ^:private prepare-method-input [idx input ^MethodVisitor method-visitor]
+ "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))"
+ (|case input
+ [_ (&/$GenericClass name params)]
+ (case name
+ "boolean" (do (doto method-visitor
+ (.visitVarInsn Opcodes/ILOAD idx)
+ &&/wrap-boolean
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))])))
+ "byte" (do (doto method-visitor
+ (.visitVarInsn Opcodes/ILOAD idx)
+ &&/wrap-byte
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))])))
+ "short" (do (doto method-visitor
+ (.visitVarInsn Opcodes/ILOAD idx)
+ &&/wrap-short
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))])))
+ "int" (do (doto method-visitor
+ (.visitVarInsn Opcodes/ILOAD idx)
+ &&/wrap-int
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))])))
+ "long" (do (doto method-visitor
+ (.visitVarInsn Opcodes/LLOAD idx)
+ &&/wrap-long
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)])))
+ "float" (do (doto method-visitor
+ (.visitVarInsn Opcodes/FLOAD idx)
+ &&/wrap-float
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))])))
+ "double" (do (doto method-visitor
+ (.visitVarInsn Opcodes/DLOAD idx)
+ &&/wrap-double
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)])))
+ "char" (do (doto method-visitor
+ (.visitVarInsn Opcodes/ILOAD idx)
+ &&/wrap-char
+ (.visitVarInsn Opcodes/ASTORE idx))
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))])))
+ ;; else
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))])))
+
+ [_ gclass]
+ (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))]))
+ ))
+
+(defn ^:private prepare-method-inputs [idx inputs method-visitor]
+ "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))"
+ (|case inputs
+ (&/$Nil)
+ (return &/$Nil)
+
+ (&/$Cons input inputs*)
+ (|do [[_ outputs*] (&/fold% (fn [idx+outputs input]
+ (|do [:let [[_idx _outputs] idx+outputs]
+ [idx* output] (prepare-method-input _idx input method-visitor)]
+ (return (&/T [idx* (&/$Cons output _outputs)]))))
+ (&/T [idx &/$Nil])
+ inputs)]
+ (return (&/list-join (&/|reverse outputs*))))
+ ))
+
+(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def]
+ (|case method-def
+ (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body)
+ (|let [?output (&/$GenericClass "void" (&/|list))
+ =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ (+ (&host/privacy-modifier->flag ?privacy-modifier)
+ (if ?strict Opcodes/ACC_STRICT 0))
+ init-method
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [[super-class-name super-class-params] ?super-class
+ init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str ""))
+ init-sig (str "(" init-types ")" "V")
+ _ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitCode =method)]
+ =input-tags (prepare-method-inputs 1 ?inputs =method)
+ :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)]
+ _ (->> ?ctor-args (&/|map &/|second) (&/map% compile))
+ :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)]
+ _ (compile (&o/optimize ?body))
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+
+ (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ (+ (&host/privacy-modifier->flag ?privacy-modifier)
+ (if =final? Opcodes/ACC_FINAL 0)
+ (if ?strict Opcodes/ACC_STRICT 0))
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitCode =method)]
+ =input-tags (prepare-method-inputs 1 ?inputs =method)
+ _ (compile (&o/optimize ?body))
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+
+ (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ (+ Opcodes/ACC_PUBLIC
+ (if ?strict Opcodes/ACC_STRICT 0))
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitCode =method)]
+ =input-tags (prepare-method-inputs 1 ?inputs =method)
+ _ (compile (&o/optimize ?body))
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+
+ (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body)
+ (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ (+ (&host/privacy-modifier->flag ?privacy-modifier)
+ (if ?strict Opcodes/ACC_STRICT 0)
+ Opcodes/ACC_STATIC)
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitCode =method)]
+ =input-tags (prepare-method-inputs 0 ?inputs =method)
+ _ (compile (&o/optimize ?body))
+ :let [_ (doto =method
+ (compile-method-return ?output)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil))))
+
+ (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
+ (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ (+ Opcodes/ACC_ABSTRACT
+ (&host/privacy-modifier->flag ?privacy-modifier))
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitEnd =method)]]
+ (return nil))))
+
+ (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output)
+ (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output])
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)]
+ (&/with-writer (.visitMethod class-writer
+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE
+ (&host/privacy-modifier->flag ?privacy-modifier))
+ ?name
+ simple-signature
+ generic-signature
+ (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (&/|map (partial compile-annotation =method) ?anns)
+ _ (.visitEnd =method)]]
+ (return nil))))
+ ))
+
+(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl]
+ (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl
+ [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)
+ =method (.visitMethod class-writer
+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT)
+ =name
+ simple-signature
+ generic-signature
+ (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String)))
+ _ (&/|map (partial compile-annotation =method) =anns)
+ _ (.visitEnd =method)]
+ nil))
+
+(defn ^:private prepare-ctor-arg [^MethodVisitor writer type]
+ (case type
+ "boolean" (doto writer
+ &&/unwrap-boolean)
+ "byte" (doto writer
+ &&/unwrap-byte)
+ "short" (doto writer
+ &&/unwrap-short)
+ "int" (doto writer
+ &&/unwrap-int)
+ "long" (doto writer
+ &&/unwrap-long)
+ "float" (doto writer
+ &&/unwrap-float)
+ "double" (doto writer
+ &&/unwrap-double)
+ "char" (doto writer
+ &&/unwrap-char)
+ ;; else
+ (doto writer
+ (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type)))))
+
+(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object")
+ <init>-return "V"]
+ (defn ^:private anon-class-<init>-signature [env]
+ (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")"
+ <init>-return))
+
+ (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args]
+ (|let [[super-class-name super-class-params] super-class
+ init-types (->> ctor-args (&/|map (comp &host-generics/->type-signature &/|first)) (&/fold str ""))]
+ (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class-<init>-signature env) nil nil)
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (doto =method
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0))]
+ _ (&/map% (fn [type+term]
+ (|let [[type term] type+term]
+ (|do [_ (compile term)
+ :let [_ (prepare-ctor-arg =method type)]]
+ (return nil))))
+ ctor-args)
+ :let [_ (doto =method
+ (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" <init>-return))
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD (inc ?captured-id))
+ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
+ (|case ?name+?captured
+ [?name [_ (&o/$captured _ ?captured-id ?source)]])
+ (doseq [?name+?captured (&/->seq env)])))
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))))
+ )
+
+(defn ^:private constant-inits [fields]
+ "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))"
+ (&/fold &/|++
+ &/$Nil
+ (&/|map (fn [field]
+ (|case field
+ (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value)
+ (&/|list (&/T [?name ?gclass ?value]))
+
+ (&/$VariableFieldSyntax _)
+ (&/|list)
+ ))
+ fields)))
+
+(declare compile-jvm-putstatic)
+(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args]
+ (|do [module &/get-module-name
+ [file-name line column] &/cursor
+ :let [[?name ?params] class-decl
+ class-signature (&host-generics/gclass-decl->signature class-decl (&/$Cons ?super-class ?interfaces))
+ full-name (str module "/" ?name)
+ super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class))
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
+ (&host/inheritance-modifier->flag ?inheritance-modifier))
+ full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
+ (.visitSource file-name nil))
+ _ (&/|map (partial compile-annotation =class) ?anns)
+ _ (&/|map (partial compile-field =class)
+ ?fields)]
+ _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods)
+ _ (|case ??ctor-args
+ (&/$Some ctor-args)
+ (add-anon-class-<init> =class compile full-name ?super-class env ctor-args)
+
+ _
+ (return nil))
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor =method &/get-writer
+ :let [_ (doto =method
+ (.visitCode))]
+ _ (&/map% (fn [ftriple]
+ (|let [[fname fgclass fvalue] ftriple]
+ (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass))))
+ (constant-inits ?fields))
+ :let [_ (doto =method
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))]
+ (&&/save-class! ?name (.toByteArray (doto =class .visitEnd)))))
+
+(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods]
+ (|do [:let [[interface-name interface-vars] interface-decl]
+ module &/get-module-name
+ [file-name _ _] &/cursor
+ :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers)
+ =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE)
+ (str module "/" interface-name)
+ (if (= "" interface-signature) nil interface-signature)
+ "java/lang/Object"
+ (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))
+ (.visitSource file-name nil))
+ _ (&/|map (partial compile-annotation =interface) ?anns)
+ _ (do (&/|map (partial compile-method-decl =interface) ?methods)
+ (.visitEnd =interface))]]
+ (&&/save-class! interface-name (.toByteArray =interface))))
+
+(defn ^:private compile-jvm-try [compile ?values special-args]
+ (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ :let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)
+ $end (new Label)]
+ :let [_ (doto *writer*
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitLabel $from))]
+ _ (compile ?body)
+ :let [_ (doto *writer*
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $to)
+ (.visitLabel $handler))]
+ _ (compile ?catch)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
+ (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil)))
+
+(do-template [<name> <op> <unwrap> <wrap>]
+ (defn <name> [compile _?value special-args]
+ (|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?value)
+ :let [_ (doto *writer*
+ <unwrap>
+ (.visitInsn <op>)
+ <wrap>)]]
+ (return nil)))
+
+ ^:private compile-jvm-d2f Opcodes/D2F &&/unwrap-double &&/wrap-float
+ ^:private compile-jvm-d2i Opcodes/D2I &&/unwrap-double &&/wrap-int
+ ^:private compile-jvm-d2l Opcodes/D2L &&/unwrap-double &&/wrap-long
+
+ ^:private compile-jvm-f2d Opcodes/F2D &&/unwrap-float &&/wrap-double
+ ^:private compile-jvm-f2i Opcodes/F2I &&/unwrap-float &&/wrap-int
+ ^:private compile-jvm-f2l Opcodes/F2L &&/unwrap-float &&/wrap-long
+
+ ^:private compile-jvm-i2b Opcodes/I2B &&/unwrap-int &&/wrap-byte
+ ^:private compile-jvm-i2c Opcodes/I2C &&/unwrap-int &&/wrap-char
+ ^:private compile-jvm-i2d Opcodes/I2D &&/unwrap-int &&/wrap-double
+ ^:private compile-jvm-i2f Opcodes/I2F &&/unwrap-int &&/wrap-float
+ ^:private compile-jvm-i2l Opcodes/I2L &&/unwrap-int &&/wrap-long
+ ^:private compile-jvm-i2s Opcodes/I2S &&/unwrap-int &&/wrap-short
+
+ ^:private compile-jvm-l2d Opcodes/L2D &&/unwrap-long &&/wrap-double
+ ^:private compile-jvm-l2f Opcodes/L2F &&/unwrap-long &&/wrap-float
+ ^:private compile-jvm-l2i Opcodes/L2I &&/unwrap-long &&/wrap-int
+
+ ^:private compile-jvm-c2b Opcodes/I2B &&/unwrap-char &&/wrap-byte
+ ^:private compile-jvm-c2s Opcodes/I2S &&/unwrap-char &&/wrap-short
+ ^:private compile-jvm-c2i Opcodes/NOP &&/unwrap-char &&/wrap-int
+ ^:private compile-jvm-c2l Opcodes/I2L &&/unwrap-char &&/wrap-long
+
+ ^:private compile-jvm-s2l Opcodes/I2L &&/unwrap-short &&/wrap-long
+
+ ^:private compile-jvm-b2l Opcodes/I2L &&/unwrap-byte &&/wrap-long
+ )
+
+(do-template [<name> <op> <wrap>]
+ (defn <name> [compile _?value special-args]
+ (|do [:let [(&/$Cons ?value (&/$Nil)) _?value]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?value)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I)
+ (.visitInsn <op>)
+ <wrap>)]]
+ (return nil)))
+
+ ^:private compile-jvm-l2s Opcodes/I2S &&/wrap-short
+ ^:private compile-jvm-l2b Opcodes/I2B &&/wrap-byte
+ )
+
+(do-template [<name> <op> <unwrap-left> <unwrap-right> <wrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap-left>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap-right>)]
+ :let [_ (doto *writer*
+ (.visitInsn <op>)
+ <wrap>)]]
+ (return nil)))
+
+ ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int
+
+ ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long
+ ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long
+ ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long
+ )
+
+(do-template [<name> <opcode> <unwrap> <wrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap>)
+ _ (doto *writer*
+ (.visitInsn <opcode>)
+ (<wrap>))]]
+ (return nil)))
+
+ ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int
+ ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int
+
+ ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long
+ ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long
+
+ ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float
+ ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float
+ ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float
+ ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float
+ ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float
+
+ ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double
+ ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double
+ ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double
+ ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double
+ ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double
+ )
+
+(do-template [<name> <opcode> <unwrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap>)
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitJumpInsn <opcode> $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int
+ ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int
+ ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int
+
+ ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char
+ ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char
+ ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char
+ )
+
+(do-template [<name> <cmpcode> <cmp-output> <unwrap>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ <unwrap>)]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ <unwrap>)
+ $then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitInsn <cmpcode>)
+ (.visitLdcInsn (int <cmp-output>))
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+ ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long
+ ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long
+ ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long
+
+ ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float
+ ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float
+ ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float
+
+ ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double
+ ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double
+ ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double
+ )
+
+(do-template [<prim-type> <array-type> <new-name> <load-name> <load-op> <store-name> <store-op> <wrapper> <unwrapper>]
+ (do (defn <new-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?length)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY <prim-type>)]]
+ (return nil)))
+
+ (defn <load-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitInsn <load-op>)
+ <wrapper>)]]
+ (return nil)))
+
+ (defn <store-name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST <array-type>)]
+ :let [_ (.visitInsn *writer* Opcodes/DUP)]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ _ (compile ?elem)
+ :let [_ (doto *writer*
+ <unwrapper>
+ (.visitInsn <store-op>))]]
+ (return nil)))
+ )
+
+ Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean
+ Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte
+ Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short
+ Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int
+ Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long
+ Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float
+ Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double
+ Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char
+ )
+
+(defn ^:private compile-jvm-anewarray [compile ?values special-args]
+ (|do [:let [(&/$Cons ?length (&/$Nil)) ?values
+ (&/$Cons ?gclass (&/$Cons type-env (&/$Nil))) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?length)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-aaload [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ array-type (&host/->java-sig (&a/expr-type* ?array))
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-aastore [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ array-type (&host/->java-sig (&a/expr-type* ?array))
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
+ :let [_ (.visitInsn *writer* Opcodes/DUP)]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ _ (compile ?elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-arraylength [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Nil)) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ array-type (&host/->java-sig (&a/expr-type* ?array))
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARRAYLENGTH)
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-null [compile ?values special-args]
+ (|do [:let [;; (&/$Nil) ?values
+ (&/$Nil) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-null? [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?object)
+ :let [$then (new Label)
+ $end (new Label)
+ _ (doto *writer*
+ (.visitJumpInsn Opcodes/IFNULL $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $then)
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean"))
+ (.visitLabel $end))]]
+ (return nil)))
+
+(defn compile-jvm-synchronized [compile ?values special-args]
+ (|do [:let [(&/$Cons ?monitor (&/$Cons ?expr (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?monitor)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitInsn Opcodes/MONITORENTER))]
+ _ (compile ?expr)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/SWAP)
+ (.visitInsn Opcodes/MONITOREXIT))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-throw [compile ?values special-args]
+ (|do [:let [(&/$Cons ?ex (&/$Nil)) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?ex)
+ :let [_ (.visitInsn *writer* Opcodes/ATHROW)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-getstatic [compile ?values special-args]
+ (|do [:let [;; (&/$Nil) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ =output-type (&host/->java-sig ?output-type)
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type)
+ (prepare-return! ?output-type))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-getfield [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object (&/$Nil)) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons ?output-type (&/$Nil)))) special-args]
+ :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?object)
+ =output-type (&host/->java-sig ?output-type)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST class*)
+ (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type)
+ (prepare-return! ?output-type))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-putstatic [compile ?values special-args]
+ (|do [:let [(&/$Cons ?value (&/$Nil)) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Nil)))) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?value)
+ :let [=input-sig (&host-type/gclass->sig input-gclass)
+ _ (doto *writer*
+ (prepare-arg! (&host-generics/gclass->class-name input-gclass))
+ (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig)
+ (.visitInsn Opcodes/ACONST_NULL))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-putfield [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object (&/$Cons ?value (&/$Nil))) ?values
+ (&/$Cons ?class (&/$Cons ?field (&/$Cons input-gclass (&/$Cons ?input-type (&/$Nil))))) special-args]
+ :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?object)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)]
+ _ (compile ?value)
+ =input-sig (&host/->java-sig ?input-type)
+ :let [_ (doto *writer*
+ (prepare-arg! (&host-generics/gclass->class-name input-gclass))
+ (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig)
+ (.visitInsn Opcodes/ACONST_NULL))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-invokestatic [compile ?values special-args]
+ (|do [:let [?args ?values
+ (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
+ _ (&/map2% (fn [class-name arg]
+ (|do [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ ?classes ?args)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig)
+ (prepare-return! ?output-type))]]
+ (return nil)))
+
+(do-template [<name> <op>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?object ?args) ?values
+ (&/$Cons ?class (&/$Cons ?method (&/$Cons ?classes (&/$Cons ?output-type (&/$Cons ?gret (&/$Nil)))))) special-args]
+ :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))]
+ ^MethodVisitor *writer* &/get-writer
+ :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))]
+ _ (compile ?object)
+ :let [_ (when (not= "<init>" ?method)
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))]
+ _ (&/map2% (fn [class-name arg]
+ (|do [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ ?classes ?args)
+ :let [_ (doto *writer*
+ (.visitMethodInsn <op> ?class* ?method method-sig)
+ (prepare-return! ?output-type))]]
+ (return nil)))
+
+ ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL
+ ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE
+ ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL
+ )
+
+(defn ^:private compile-jvm-new [compile ?values special-args]
+ (|do [:let [?args ?values
+ (&/$Cons ?class (&/$Cons ?classes (&/$Nil))) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V")
+ class* (&host-generics/->bytecode-class-name ?class)
+ _ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW class*)
+ (.visitInsn Opcodes/DUP))]
+ _ (&/map% (fn [class-name+arg]
+ (|do [:let [[class-name arg] class-name+arg]
+ ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (&/zip2 ?classes ?args))
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-try [compile ?values special-args]
+ (|do [:let [(&/$Cons ?body (&/$Cons ?catch (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ :let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)
+ $end (new Label)]
+ :let [_ (doto *writer*
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitLabel $from))]
+ _ (compile ?body)
+ :let [_ (doto *writer*
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $to)
+ (.visitLabel $handler))]
+ _ (compile ?catch)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
+ (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))]
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-load-class [compile ?values special-args]
+ (|do [:let [(&/$Cons _class-name (&/$Cons ?output-type (&/$Nil))) special-args]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitLdcInsn _class-name)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;")
+ (prepare-return! ?output-type))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-instanceof [compile ?values special-args]
+ (|do [:let [(&/$Cons object (&/$Nil)) ?values
+ (&/$Cons class (&/$Nil)) special-args]
+ :let [class* (&host-generics/->bytecode-class-name class)]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile object)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/INSTANCEOF class*)
+ (&&/wrap-boolean))]]
+ (return nil)))
+
+(defn compile-proc [compile proc-name ?values special-args]
+ (case proc-name
+ "synchronized" (compile-jvm-synchronized compile ?values special-args)
+ "load-class" (compile-jvm-load-class compile ?values special-args)
+ "instanceof" (compile-jvm-instanceof compile ?values special-args)
+ "try" (compile-jvm-try compile ?values special-args)
+ "new" (compile-jvm-new compile ?values special-args)
+ "invokestatic" (compile-jvm-invokestatic compile ?values special-args)
+ "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args)
+ "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args)
+ "invokespecial" (compile-jvm-invokespecial compile ?values special-args)
+ "getstatic" (compile-jvm-getstatic compile ?values special-args)
+ "getfield" (compile-jvm-getfield compile ?values special-args)
+ "putstatic" (compile-jvm-putstatic compile ?values special-args)
+ "putfield" (compile-jvm-putfield compile ?values special-args)
+ "throw" (compile-jvm-throw compile ?values special-args)
+ "null?" (compile-jvm-null? compile ?values special-args)
+ "null" (compile-jvm-null compile ?values special-args)
+ "anewarray" (compile-jvm-anewarray compile ?values special-args)
+ "aaload" (compile-jvm-aaload compile ?values special-args)
+ "aastore" (compile-jvm-aastore compile ?values special-args)
+ "arraylength" (compile-jvm-arraylength compile ?values special-args)
+ "znewarray" (compile-jvm-znewarray compile ?values special-args)
+ "bnewarray" (compile-jvm-bnewarray compile ?values special-args)
+ "snewarray" (compile-jvm-snewarray compile ?values special-args)
+ "inewarray" (compile-jvm-inewarray compile ?values special-args)
+ "lnewarray" (compile-jvm-lnewarray compile ?values special-args)
+ "fnewarray" (compile-jvm-fnewarray compile ?values special-args)
+ "dnewarray" (compile-jvm-dnewarray compile ?values special-args)
+ "cnewarray" (compile-jvm-cnewarray compile ?values special-args)
+ "iadd" (compile-jvm-iadd compile ?values special-args)
+ "isub" (compile-jvm-isub compile ?values special-args)
+ "imul" (compile-jvm-imul compile ?values special-args)
+ "idiv" (compile-jvm-idiv compile ?values special-args)
+ "irem" (compile-jvm-irem compile ?values special-args)
+ "ieq" (compile-jvm-ieq compile ?values special-args)
+ "ilt" (compile-jvm-ilt compile ?values special-args)
+ "igt" (compile-jvm-igt compile ?values special-args)
+ "ceq" (compile-jvm-ceq compile ?values special-args)
+ "clt" (compile-jvm-clt compile ?values special-args)
+ "cgt" (compile-jvm-cgt compile ?values special-args)
+ "ladd" (compile-jvm-ladd compile ?values special-args)
+ "lsub" (compile-jvm-lsub compile ?values special-args)
+ "lmul" (compile-jvm-lmul compile ?values special-args)
+ "ldiv" (compile-jvm-ldiv compile ?values special-args)
+ "lrem" (compile-jvm-lrem compile ?values special-args)
+ "leq" (compile-jvm-leq compile ?values special-args)
+ "llt" (compile-jvm-llt compile ?values special-args)
+ "lgt" (compile-jvm-lgt compile ?values special-args)
+ "fadd" (compile-jvm-fadd compile ?values special-args)
+ "fsub" (compile-jvm-fsub compile ?values special-args)
+ "fmul" (compile-jvm-fmul compile ?values special-args)
+ "fdiv" (compile-jvm-fdiv compile ?values special-args)
+ "frem" (compile-jvm-frem compile ?values special-args)
+ "feq" (compile-jvm-feq compile ?values special-args)
+ "flt" (compile-jvm-flt compile ?values special-args)
+ "fgt" (compile-jvm-fgt compile ?values special-args)
+ "dadd" (compile-jvm-dadd compile ?values special-args)
+ "dsub" (compile-jvm-dsub compile ?values special-args)
+ "dmul" (compile-jvm-dmul compile ?values special-args)
+ "ddiv" (compile-jvm-ddiv compile ?values special-args)
+ "drem" (compile-jvm-drem compile ?values special-args)
+ "deq" (compile-jvm-deq compile ?values special-args)
+ "dlt" (compile-jvm-dlt compile ?values special-args)
+ "dgt" (compile-jvm-dgt compile ?values special-args)
+ "iand" (compile-jvm-iand compile ?values special-args)
+ "ior" (compile-jvm-ior compile ?values special-args)
+ "ixor" (compile-jvm-ixor compile ?values special-args)
+ "ishl" (compile-jvm-ishl compile ?values special-args)
+ "ishr" (compile-jvm-ishr compile ?values special-args)
+ "iushr" (compile-jvm-iushr compile ?values special-args)
+ "land" (compile-jvm-land compile ?values special-args)
+ "lor" (compile-jvm-lor compile ?values special-args)
+ "lxor" (compile-jvm-lxor compile ?values special-args)
+ "lshl" (compile-jvm-lshl compile ?values special-args)
+ "lshr" (compile-jvm-lshr compile ?values special-args)
+ "lushr" (compile-jvm-lushr compile ?values special-args)
+ "d2f" (compile-jvm-d2f compile ?values special-args)
+ "d2i" (compile-jvm-d2i compile ?values special-args)
+ "d2l" (compile-jvm-d2l compile ?values special-args)
+ "f2d" (compile-jvm-f2d compile ?values special-args)
+ "f2i" (compile-jvm-f2i compile ?values special-args)
+ "f2l" (compile-jvm-f2l compile ?values special-args)
+ "i2b" (compile-jvm-i2b compile ?values special-args)
+ "i2c" (compile-jvm-i2c compile ?values special-args)
+ "i2d" (compile-jvm-i2d compile ?values special-args)
+ "i2f" (compile-jvm-i2f compile ?values special-args)
+ "i2l" (compile-jvm-i2l compile ?values special-args)
+ "i2s" (compile-jvm-i2s compile ?values special-args)
+ "l2d" (compile-jvm-l2d compile ?values special-args)
+ "l2f" (compile-jvm-l2f compile ?values special-args)
+ "l2i" (compile-jvm-l2i compile ?values special-args)
+ "l2s" (compile-jvm-l2s compile ?values special-args)
+ "l2b" (compile-jvm-l2b compile ?values special-args)
+ "c2b" (compile-jvm-c2b compile ?values special-args)
+ "c2s" (compile-jvm-c2s compile ?values special-args)
+ "c2i" (compile-jvm-c2i compile ?values special-args)
+ "c2l" (compile-jvm-c2l compile ?values special-args)
+ "s2l" (compile-jvm-s2l compile ?values special-args)
+ "b2l" (compile-jvm-b2l compile ?values special-args)
+ ;; else
+ (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["jvm" proc-name]))))
diff --git a/luxc/src/lux/compiler/jvm/rt.clj b/luxc/src/lux/compiler/jvm/rt.clj
new file mode 100644
index 000000000..97c7d849c
--- /dev/null
+++ b/luxc/src/lux/compiler/jvm/rt.clj
@@ -0,0 +1,1476 @@
+(ns lux.compiler.jvm.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.type.host :as &host-type]
+ [lux.host.generics :as &host-generics]
+ [lux.analyser.base :as &a]
+ [lux.compiler.jvm.base :as &&])
+ (:import (org.objectweb.asm Opcodes
+ Label
+ ClassWriter
+ MethodVisitor
+ AnnotationVisitor)))
+
+;; [Utils]
+(def init-method "<init>")
+
+;; [Resources]
+;; Functions
+(def compile-Function-class
+ (|do [_ (return nil)
+ :let [super-class "java/lang/Object"
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER
+ Opcodes/ACC_ABSTRACT
+ ;; Opcodes/ACC_INTERFACE
+ )
+ &&/function-class nil super-class (into-array String []))
+ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil)
+ (doto (.visitEnd))))
+ =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (dotimes [arity* &&/num-apply-variants]
+ (let [arity (inc arity*)]
+ (if (= 1 arity)
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil)
+ (.visitEnd))
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil)
+ (.visitCode)
+ (-> (.visitVarInsn Opcodes/ALOAD idx)
+ (->> (dotimes [idx arity])))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity)))
+ (.visitTypeInsn Opcodes/CHECKCAST &&/function-class)
+ (.visitVarInsn Opcodes/ALOAD arity)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1))
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))))]]
+ (&&/save-class! (second (string/split &&/function-class #"/"))
+ (.toByteArray (doto =class .visitEnd)))))
+
+;; Custom Runnable
+(def compile-LuxRunnable-class
+ (|do [_ (return nil)
+ :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ "lux/LuxRunnable" nil "java/lang/Object" (into-array String ["java/lang/Runnable"])))
+ _ (doto (.visitField =class Opcodes/ACC_PUBLIC "procedure" "Llux/Function;" nil nil)
+ (.visitEnd))
+ _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(Llux/Function;)V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" init-method "()V")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitFieldInsn Opcodes/PUTFIELD "lux/LuxRunnable" "procedure" "Llux/Function;")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "run" "()V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD "lux/LuxRunnable" "procedure" "Llux/Function;")
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1))
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (&&/save-class! "LuxRunnable"
+ (.toByteArray (doto =class .visitEnd)))))
+
+;; Runtime infrastructure
+(defn ^:private compile-LuxRT-adt-methods [^ClassWriter =class]
+ (|let [_ (let [$begin (new Label)
+ $not-rec (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getLeft" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLabel $begin)
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
+ (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
+ (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
+ (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
+ (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
+ (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
+ (.visitJumpInsn Opcodes/IF_ICMPGT $not-rec) ;; tuple-size, index-last-elem
+ (.visitInsn Opcodes/SWAP) ;; index-last-elem, tuple-size
+ (.visitInsn Opcodes/ISUB) ;; sub-index
+ (.visitVarInsn Opcodes/ALOAD 0) ;; sub-index, tuple
+ (.visitInsn Opcodes/DUP) ;; sub-index, tuple, tuple
+ (.visitInsn Opcodes/ARRAYLENGTH) ;; sub-index, tuple, tuple-size
+ (.visitLdcInsn (int 1)) ;; sub-index, tuple, tuple-size, offset-last-elem
+ (.visitInsn Opcodes/ISUB) ;; sub-index, tuple, index-last-elem
+ (.visitInsn Opcodes/AALOAD) ;; sub-index, sub-tuple
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitVarInsn Opcodes/ASTORE 0) ;; sub-index
+ (.visitVarInsn Opcodes/ISTORE 1) ;;
+ (.visitJumpInsn Opcodes/GOTO $begin)
+ (.visitLabel $not-rec) ;; tuple-size, index-last-elem
+ (.visitInsn Opcodes/POP2) ;;
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
+ (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
+ (.visitInsn Opcodes/AALOAD) ;; elem
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$begin (new Label)
+ $is-last (new Label)
+ $must-copy (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "product_getRight" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLabel $begin)
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
+ (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-size
+ (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-size, index
+ (.visitLdcInsn (int 1)) ;; tuple-size, index, offset-last-elem
+ (.visitInsn Opcodes/IADD) ;; tuple-size, index-last-elem
+ (.visitInsn Opcodes/DUP2) ;; tuple-size, index-last-elem, tuple-size, index-last-elem
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $is-last) ;; tuple-size, index-last-elem
+ (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) ;;
+ ;; Must recurse
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
+ (.visitInsn Opcodes/DUP) ;; tuple, tuple
+ (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple, tuple-size
+ (.visitLdcInsn (int 1)) ;; tuple, tuple-size, offset-last-elem
+ (.visitInsn Opcodes/ISUB) ;; tuple, offset-tuple-last-elem
+ (.visitInsn Opcodes/AALOAD) ;; tuple-tail
+ (.visitVarInsn Opcodes/ILOAD 1) ;; tuple-tail, index
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tuple-tail, index, tuple
+ (.visitInsn Opcodes/ARRAYLENGTH) ;; tuple-tail, index, tuple-size
+ (.visitLdcInsn (int 1)) ;; tuple-tail, index, tuple-size, 1
+ (.visitInsn Opcodes/ISUB) ;; tuple-tail, index, tuple-size*
+ (.visitInsn Opcodes/ISUB) ;; tuple-tail, index*
+ (.visitVarInsn Opcodes/ISTORE 1) ;; tuple-tail
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") ;; tuple-tail
+ (.visitVarInsn Opcodes/ASTORE 0) ;;
+ (.visitJumpInsn Opcodes/GOTO $begin)
+ (.visitLabel $must-copy)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ARRAYLENGTH)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $is-last) ;; tuple-size, index-last-elem
+ (.visitInsn Opcodes/POP2) ;;
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tuple
+ (.visitVarInsn Opcodes/ILOAD 1) ;; tuple, index
+ (.visitInsn Opcodes/AALOAD) ;; elem
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$begin (new Label)
+ $just-return (new Label)
+ $then (new Label)
+ $further (new Label)
+ $not-right (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLabel $begin)
+ (.visitVarInsn Opcodes/ILOAD 1) ;; tag
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum
+ (.visitLdcInsn (int 0)) ;; tag, sum, sum-tag-idx
+ (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag'
+ &&/unwrap-int ;; tag, sum-tag
+ (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; tag, sum-tag
+ (.visitInsn Opcodes/DUP2) ;; tag, sum-tag, tag, sum-tag
+ (.visitJumpInsn Opcodes/IF_ICMPGT $further) ;; tag, sum-tag
+ (.visitInsn Opcodes/POP2)
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $then) ;; tag, sum-tag
+ (.visitVarInsn Opcodes/ALOAD 2) ;; tag, sum-tag, wants-last?
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, wants-last?, is-last?
+ (.visitJumpInsn Opcodes/IF_ACMPEQ $just-return)
+ (.visitJumpInsn Opcodes/GOTO $further)
+ (.visitLabel $just-return)
+ (.visitInsn Opcodes/POP2)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 2))
+ (.visitInsn Opcodes/AALOAD)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $further) ;; tag, sum-tag
+ (.visitVarInsn Opcodes/ALOAD 0) ;; tag, sum-tag, sum
+ (.visitLdcInsn (int 1)) ;; tag, sum-tag, sum, last-index?
+ (.visitInsn Opcodes/AALOAD) ;; tag, sum-tag, last?
+ (.visitJumpInsn Opcodes/IFNULL $not-right) ;; tag, sum-tag
+ (.visitInsn Opcodes/ISUB) ;; sub-tag
+ (.visitVarInsn Opcodes/ALOAD 0) ;; sub-tag, sum
+ (.visitLdcInsn (int 2)) ;; sub-tag, sum, sub-sum-idx
+ (.visitInsn Opcodes/AALOAD) ;; sub-tag, sub-sum
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitVarInsn Opcodes/ASTORE 0) ;; sub-tag
+ (.visitVarInsn Opcodes/ISTORE 1) ;;
+ (.visitJumpInsn Opcodes/GOTO $begin)
+ (.visitLabel $not-right) ;; tag, sum-tag
+ (.visitInsn Opcodes/POP2)
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ ;; I commented-out some parts because a null-check was
+ ;; done to ensure variants were never created with null
+ ;; values (this would interfere later with
+ ;; pattern-matching).
+ ;; Since Lux itself doesn't have null values as part of
+ ;; the language, the burden of ensuring non-nulls was
+ ;; shifted to library code dealing with host-interop, to
+ ;; ensure variant-making was as fast as possible.
+ ;; The null-checking code was left as comments in case I
+ ;; ever change my mind.
+ _ (let [;; $is-null (new Label)
+ ]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ ;; (.visitVarInsn Opcodes/ALOAD 2)
+ ;; (.visitJumpInsn Opcodes/IFNULL $is-null)
+ (.visitLdcInsn (int 3))
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 0))
+ (.visitVarInsn Opcodes/ILOAD 0)
+ (&&/wrap-int)
+ (.visitInsn Opcodes/AASTORE)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 1))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitInsn Opcodes/AASTORE)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 2))
+ (.visitVarInsn Opcodes/ALOAD 2)
+ (.visitInsn Opcodes/AASTORE)
+ (.visitInsn Opcodes/ARETURN)
+ ;; (.visitLabel $is-null)
+ ;; (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
+ ;; (.visitInsn Opcodes/DUP)
+ ;; (.visitLdcInsn "Can't create variant for null pointer")
+ ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
+ ;; (.visitInsn Opcodes/ATHROW)
+ (.visitMaxs 0 0)
+ (.visitEnd)))]
+ nil))
+
+(defn ^:private low-4b [^MethodVisitor =method]
+ (doto =method
+ ;; Assume there is a long at the top of the stack...
+ ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits.
+ (.visitLdcInsn (int -1))
+ (.visitInsn Opcodes/I2L)
+ ;; Then do a bitwise and.
+ (.visitInsn Opcodes/LAND)
+ ))
+
+(defn ^:private high-4b [^MethodVisitor =method]
+ (doto =method
+ ;; Assume there is a long at the top of the stack...
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LUSHR)
+ ))
+
+(defn ^:private swap2 [^MethodVisitor =method]
+ (doto =method
+ ;; X2, Y2
+ (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2
+ (.visitInsn Opcodes/POP2) ;; Y2, X2
+ ))
+
+(defn ^:private swap2x1 [^MethodVisitor =method]
+ (doto =method
+ ;; X1, Y2
+ (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2
+ (.visitInsn Opcodes/POP2) ;; Y2, X1
+ ))
+
+(defn ^:private bit-set-64? [^MethodVisitor =method]
+ (doto =method
+ ;; L, I
+ (.visitLdcInsn (long 1)) ;; L, I, L
+ (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L
+ (.visitInsn Opcodes/POP2) ;; L, L, I
+ (.visitInsn Opcodes/LSHL) ;; L, L
+ (.visitInsn Opcodes/LAND) ;; L
+ (.visitLdcInsn (long 0)) ;; L, L
+ (.visitInsn Opcodes/LCMP) ;; I
+ ))
+
+(defn ^:private compile-LuxRT-deg-methods [^ClassWriter =class]
+ (|let [deg-bits 64
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_deg" "(JJ)J" nil nil)
+ ;; Based on: http://stackoverflow.com/a/31629280/6823464
+ (.visitCode)
+ ;; Bottom part
+ (.visitVarInsn Opcodes/LLOAD 0) low-4b
+ (.visitVarInsn Opcodes/LLOAD 2) low-4b
+ (.visitInsn Opcodes/LMUL)
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LUSHR)
+ ;; Middle part
+ (.visitVarInsn Opcodes/LLOAD 0) high-4b
+ (.visitVarInsn Opcodes/LLOAD 2) low-4b
+ (.visitInsn Opcodes/LMUL)
+ (.visitVarInsn Opcodes/LLOAD 0) low-4b
+ (.visitVarInsn Opcodes/LLOAD 2) high-4b
+ (.visitInsn Opcodes/LMUL)
+ (.visitInsn Opcodes/LADD)
+ ;; Join middle and bottom
+ (.visitInsn Opcodes/LADD)
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LUSHR)
+ ;; Top part
+ (.visitVarInsn Opcodes/LLOAD 0) high-4b
+ (.visitVarInsn Opcodes/LLOAD 2) high-4b
+ (.visitInsn Opcodes/LMUL)
+ ;; Join top with rest
+ (.visitInsn Opcodes/LADD)
+ ;; Return
+ (.visitInsn Opcodes/LRETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_deg" "(JJ)J" nil nil)
+ (.visitCode)
+ ;; Based on: http://stackoverflow.com/a/8510587/6823464
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitVarInsn Opcodes/LLOAD 2) high-4b
+ (.visitInsn Opcodes/LDIV)
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LSHL)
+ (.visitInsn Opcodes/LRETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg-to-real" "(J)D" nil nil)
+ (.visitCode)
+ ;; Translate high bytes
+ (.visitVarInsn Opcodes/LLOAD 0) high-4b
+ (.visitInsn Opcodes/L2D)
+ (.visitLdcInsn (double (Math/pow 2 32)))
+ (.visitInsn Opcodes/DDIV)
+ ;; Translate low bytes
+ (.visitVarInsn Opcodes/LLOAD 0) low-4b
+ (.visitInsn Opcodes/L2D)
+ (.visitLdcInsn (double (Math/pow 2 32)))
+ (.visitInsn Opcodes/DDIV)
+ (.visitLdcInsn (double (Math/pow 2 32)))
+ (.visitInsn Opcodes/DDIV)
+ ;; Combine and return
+ (.visitInsn Opcodes/DADD)
+ (.visitInsn Opcodes/DRETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-deg" "(D)J" nil nil)
+ (.visitCode)
+ ;; Drop any excess
+ (.visitVarInsn Opcodes/DLOAD 0)
+ (.visitLdcInsn (double 1.0))
+ (.visitInsn Opcodes/DREM)
+ ;; Shift upper half, but retain remaining decimals
+ (.visitLdcInsn (double (Math/pow 2 32)))
+ (.visitInsn Opcodes/DMUL)
+ ;; Make a copy, so the lower half can be extracted
+ (.visitInsn Opcodes/DUP2)
+ ;; Get that lower half
+ (.visitLdcInsn (double 1.0))
+ (.visitInsn Opcodes/DREM)
+ (.visitLdcInsn (double (Math/pow 2 32)))
+ (.visitInsn Opcodes/DMUL)
+ ;; Turn it into a deg
+ (.visitInsn Opcodes/D2L)
+ ;; Turn the upper half into deg too
+ swap2
+ (.visitInsn Opcodes/D2L)
+ ;; Combine both pieces
+ (.visitInsn Opcodes/LADD)
+ ;; FINISH
+ (.visitInsn Opcodes/LRETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "times5" "(I[B)[B" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (int 0)) ;; {carry}
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 0)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; {carry}
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 0)
+ (.visitInsn Opcodes/BALOAD) ;; {carry, current-digit}
+ (.visitLdcInsn (int 5))
+ (.visitInsn Opcodes/IMUL)
+ (.visitInsn Opcodes/IADD) ;; {next-raw-digit}
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 10))
+ (.visitInsn Opcodes/IREM) ;; {next-raw-digit, next-digit}
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 0)
+ swap2x1
+ (.visitInsn Opcodes/BASTORE) ;; {next-raw-digit}
+ (.visitLdcInsn (int 10))
+ (.visitInsn Opcodes/IDIV) ;; {next-carry}
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 0)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digit_power" "(I)[B" nil nil)
+ (.visitCode)
+ ;; Initialize digits array.
+ (.visitLdcInsn (int deg-bits))
+ (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE) ;; {digits}
+ (.visitInsn Opcodes/DUP)
+ (.visitVarInsn Opcodes/ILOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/BASTORE) ;; digits = 5^0
+ (.visitVarInsn Opcodes/ASTORE 1)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitVarInsn Opcodes/ILOAD 0) ;; {times}
+ (.visitLabel $loop-start)
+ (.visitInsn Opcodes/DUP)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ ;; {times}
+ (.visitVarInsn Opcodes/ILOAD 0)
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "times5" "(I[B)[B") ;; {digits*5, times}
+ (.visitVarInsn Opcodes/ASTORE 1) ;; {times}
+ ;; Decrement index
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ ;; {times-1}
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "add_deg_digit_powers" "([B[B)[B" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (int (dec deg-bits)))
+ (.visitVarInsn Opcodes/ISTORE 2) ;; Index
+ (.visitLdcInsn (int deg-bits))
+ (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
+ (.visitVarInsn Opcodes/ASTORE 3) ;; added_digits
+ (.visitLdcInsn (int 0)) ;; {carry}
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; {carry}
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ ;; {carry}
+ (.visitVarInsn Opcodes/ALOAD 3)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; {carry}
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitInsn Opcodes/BALOAD) ;; {carry, dL}
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitInsn Opcodes/BALOAD) ;; {carry, dL, dR}
+ (.visitInsn Opcodes/IADD)
+ (.visitInsn Opcodes/IADD) ;; {raw-next-digit}
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 10))
+ (.visitInsn Opcodes/IREM) ;; {raw-next-digit, next-digit}
+ (.visitVarInsn Opcodes/ALOAD 3)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ swap2x1
+ (.visitInsn Opcodes/BASTORE) ;; {raw-next-digit}
+ (.visitLdcInsn (int 10))
+ (.visitInsn Opcodes/IDIV) ;; {next-carry}
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 2)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_to_text" "([B)Ljava/lang/String;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (int (dec deg-bits)))
+ (.visitVarInsn Opcodes/ISTORE 1) ;; Index
+ (.visitLdcInsn "") ;; {text}
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitInsn Opcodes/BALOAD) ;; {text, digit}
+ (.visitLdcInsn (int 10)) ;; {text, digit, radix}
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "forDigit" "(II)C") ;; {text, digit-char}
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "toString" "(C)Ljava/lang/String;") ;; {text, digit-char-text}
+ (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 1)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)
+ $not-set (new Label)
+ $next-iteration (new Label)
+ $normal-path (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_deg" "(J)Ljava/lang/String;" nil nil)
+ (.visitCode)
+ ;; A quick corner-case to handle.
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFNE $normal-path)
+ (.visitLdcInsn ".0")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $normal-path)
+ ;; Normal case
+ (.visitLdcInsn (int (dec deg-bits)))
+ (.visitVarInsn Opcodes/ISTORE 2) ;; Index
+ (.visitLdcInsn (int deg-bits))
+ (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
+ (.visitVarInsn Opcodes/ASTORE 3) ;; digits
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ ;; Prepare text to return.
+ (.visitVarInsn Opcodes/ALOAD 3)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_to_text" "([B)Ljava/lang/String;")
+ (.visitLdcInsn ".")
+ (.visitInsn Opcodes/SWAP)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
+ ;; Trim unnecessary 0s at the end...
+ (.visitLdcInsn "0*$")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;")
+ (.visitLdcInsn (int 0))
+ (.visitInsn Opcodes/AALOAD)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ bit-set-64?
+ (.visitJumpInsn Opcodes/IFEQ $next-iteration)
+ (.visitLdcInsn (int (dec deg-bits)))
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitInsn Opcodes/ISUB)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B")
+ (.visitVarInsn Opcodes/ALOAD 3)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "add_deg_digit_powers" "([B[B)[B")
+ (.visitVarInsn Opcodes/ASTORE 3)
+ (.visitJumpInsn Opcodes/GOTO $next-iteration)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $next-iteration)
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 2)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)
+ $not-set (new Label)
+ $next-iteration (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_text_to_digits" "(Ljava/lang/String;)[B" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 1) ;; Index
+ (.visitLdcInsn (int deg-bits))
+ (.visitIntInsn Opcodes/NEWARRAY Opcodes/T_BYTE)
+ (.visitVarInsn Opcodes/ASTORE 2) ;; digits
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 2)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/IADD)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Byte" "parseByte" "(Ljava/lang/String;)B")
+ ;; Set digit
+ (.visitVarInsn Opcodes/ALOAD 2)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ swap2x1
+ (.visitInsn Opcodes/BASTORE)
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 1)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)
+ $is-less-than (new Label)
+ $is-equal (new Label)]
+ ;; [B0 <= [B1
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_lt" "([B[B)Z" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (int 0))
+ (.visitVarInsn Opcodes/ISTORE 2) ;; Index
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitLdcInsn (int deg-bits))
+ (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round)
+ (.visitLdcInsn false)
+ (.visitInsn Opcodes/IRETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitInsn Opcodes/BALOAD) ;; {D0}
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitInsn Opcodes/BALOAD) ;; {D0, D1}
+ (.visitInsn Opcodes/DUP2)
+ (.visitJumpInsn Opcodes/IF_ICMPLT $is-less-than)
+ (.visitJumpInsn Opcodes/IF_ICMPEQ $is-equal)
+ ;; Is greater than...
+ (.visitLdcInsn false)
+ (.visitInsn Opcodes/IRETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $is-less-than)
+ (.visitInsn Opcodes/POP2)
+ (.visitLdcInsn true)
+ (.visitInsn Opcodes/IRETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $is-equal)
+ ;; Increment index
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/IADD)
+ (.visitVarInsn Opcodes/ISTORE 2)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)
+ $simple-sub (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub_once" "([BBI)[B" nil nil)
+ (.visitCode)
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digit}
+ (.visitInsn Opcodes/BALOAD)
+ (.visitVarInsn Opcodes/ILOAD 1) ;; {target-digit, param-digit}
+ (.visitInsn Opcodes/DUP2)
+ (.visitJumpInsn Opcodes/IF_ICMPGE $simple-sub)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Since $0 < $1
+ (.visitInsn Opcodes/SWAP)
+ (.visitInsn Opcodes/ISUB) ;; $1 - $0
+ (.visitLdcInsn (byte 10))
+ (.visitInsn Opcodes/SWAP)
+ (.visitInsn Opcodes/ISUB) ;; 10 - ($1 - $0)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ swap2x1
+ (.visitInsn Opcodes/BASTORE)
+ ;; Prepare to iterate...
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 2)
+ ;; Subtract 1 from next digit
+ (.visitLdcInsn (int 1))
+ (.visitVarInsn Opcodes/ISTORE 1)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $simple-sub)
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ swap2x1
+ (.visitInsn Opcodes/BASTORE)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$loop-start (new Label)
+ $do-a-round (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "deg_digits_sub" "([B[B)[B" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (int (dec deg-bits)))
+ (.visitVarInsn Opcodes/ISTORE 2) ;; Index
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitJumpInsn Opcodes/IFGE $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0) ;; {target-digits}
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitInsn Opcodes/BALOAD) ;; {target-digits, param-digit}
+ (.visitVarInsn Opcodes/ILOAD 2) ;; {target-digits, param-digit, idx}
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub_once" "([BBI)[B")
+ (.visitVarInsn Opcodes/ASTORE 0) ;; Update target digits
+ ;; Decrement index
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitVarInsn Opcodes/ISTORE 2)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)
+ $loop-start (new Label)
+ $do-a-round (new Label)
+ $skip-power (new Label)
+ $iterate (new Label)
+ $bad-format (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_deg" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ ;; Check prefix
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn ".")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z")
+ (.visitJumpInsn Opcodes/IFEQ $bad-format)
+ ;; Check if size is valid
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
+ (.visitLdcInsn (int (inc deg-bits))) ;; It's increased, to account for the prefix .
+ (.visitJumpInsn Opcodes/IF_ICMPGT $bad-format)
+ ;; Initialization
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;")
+ (.visitLabel $from)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_text_to_digits" "(Ljava/lang/String;)[B")
+ (.visitLabel $to)
+ (.visitVarInsn Opcodes/ASTORE 0) ;; From test to digits...
+ (.visitLdcInsn (int 0))
+ (.visitVarInsn Opcodes/ISTORE 1) ;; Index
+ (.visitLdcInsn (long 0))
+ (.visitVarInsn Opcodes/LSTORE 2) ;; Output
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $loop-start)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitLdcInsn (int deg-bits))
+ (.visitJumpInsn Opcodes/IF_ICMPLT $do-a-round)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ &&/wrap-long
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $do-a-round)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digit_power" "(I)[B")
+ (.visitInsn Opcodes/DUP2)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_lt" "([B[B)Z")
+ (.visitJumpInsn Opcodes/IFNE $skip-power)
+ ;; Subtract power
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "deg_digits_sub" "([B[B)[B")
+ (.visitVarInsn Opcodes/ASTORE 0)
+ ;; Set bit on output
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitLdcInsn (long 1))
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitLdcInsn (int (dec deg-bits)))
+ (.visitInsn Opcodes/SWAP)
+ (.visitInsn Opcodes/ISUB)
+ (.visitInsn Opcodes/LSHL)
+ (.visitInsn Opcodes/LOR)
+ (.visitVarInsn Opcodes/LSTORE 2)
+ (.visitJumpInsn Opcodes/GOTO $iterate)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $skip-power)
+ (.visitInsn Opcodes/POP2)
+ ;; (.visitJumpInsn Opcodes/GOTO $iterate)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $iterate)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/IADD)
+ (.visitVarInsn Opcodes/ISTORE 1)
+ ;; Iterate
+ (.visitJumpInsn Opcodes/GOTO $loop-start)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $handler)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitLabel $bad-format)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))]
+ nil))
+
+(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")]
+ (defn ^:private compile-LuxRT-nat-methods [^ClassWriter =class]
+ (|let [;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#677
+ _ (let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)
+
+ $good-start (new Label)
+ $short-enough (new Label)
+ $bad-digit (new Label)
+ $out-of-bounds (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitLabel $from)
+ ;; Remove the + at the beginning...
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 0))
+ (.visitLdcInsn (int 1))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
+ (.visitLdcInsn "+")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z")
+ (.visitJumpInsn Opcodes/IFNE $good-start)
+ ;; Doesn't start with +
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ ;; Starts with +
+ (.visitLabel $good-start)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
+ (.visitVarInsn Opcodes/ASTORE 0) ;; Removed the + prefix...
+ ;; Begin parsing processs
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
+ (.visitLdcInsn (int 18))
+ (.visitJumpInsn Opcodes/IF_ICMPLE $short-enough)
+ ;; Too long
+ ;; Get prefix...
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 0))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
+ (.visitInsn Opcodes/DUP2) ;; Clone prefix, for later...
+ ;; Get last digit...
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I")
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/ISUB)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C")
+ (.visitLdcInsn (int 10))
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Character" "digit" "(CI)I")
+ ;; Test last digit...
+ (.visitInsn Opcodes/DUP)
+ (.visitJumpInsn Opcodes/IFLT $bad-digit)
+ ;; Good digit...
+ ;; Stack: prefix::L, prefix::L, last-digit::I
+ (.visitInsn Opcodes/I2L)
+ ;; Build the result...
+ swap2
+ (.visitLdcInsn (long 10))
+ (.visitInsn Opcodes/LMUL)
+ (.visitInsn Opcodes/LADD) ;; Stack: prefix::L, result::L
+ (.visitInsn Opcodes/DUP2_X2) ;; Stack: result::L, prefix::L, result::L
+ swap2 ;; Stack: result::L, result::L, prefix::L
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
+ (.visitJumpInsn Opcodes/IFLT $out-of-bounds)
+ ;; Within bounds
+ ;; Stack: result::L
+ &&/wrap-long
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ ;; Out of bounds
+ (.visitLabel $out-of-bounds)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ ;; Bad digit...
+ (.visitLabel $bad-digit)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ ;; 18 chars or less
+ (.visitLabel $short-enough)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseLong" "(Ljava/lang/String;)J")
+ &&/wrap-long
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $to)
+ (.visitLabel $handler)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172
+ _ (let [$too-big (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn "+")
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFLT $too-big)
+ ;; then
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
+ (.visitInsn Opcodes/ARETURN)
+ ;; else
+ (.visitLabel $too-big)
+ ;; Set up parts of the number string...
+ ;; First digits
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/LUSHR)
+ (.visitLdcInsn (long 5))
+ (.visitInsn Opcodes/LDIV) ;; quot
+ ;; Last digit
+ (.visitInsn Opcodes/DUP2)
+ (.visitLdcInsn (long 10))
+ (.visitInsn Opcodes/LMUL)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ swap2
+ (.visitInsn Opcodes/LSUB) ;; quot, rem
+ ;; Conversion to string...
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem*
+ (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem*
+ (.visitInsn Opcodes/POP) ;; rem*, quot
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot*
+ (.visitInsn Opcodes/SWAP) ;; quot*, rem*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
+ _ (let [$simple-case (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFGE $simple-case)
+ ;; else
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LUSHR)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
+ (.visitLdcInsn (int 32))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "shiftLeft" "(I)Ljava/math/BigInteger;")
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LSHL)
+ (.visitLdcInsn (int 32))
+ (.visitInsn Opcodes/LUSHR)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "add" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
+ (.visitInsn Opcodes/ARETURN)
+ ;; then
+ (.visitLabel $simple-case)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/math/BigInteger" "valueOf" "(J)Ljava/math/BigInteger;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_compareUnsigned" "(JJ)I" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
+ (.visitInsn Opcodes/LADD)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Long" "MIN_VALUE" "J")
+ (.visitInsn Opcodes/LADD)
+ (.visitInsn Opcodes/LCMP)
+ (.visitInsn Opcodes/IRETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290
+ _ (let [$case-1 (new Label)
+ $0 (new Label)
+ $case-2 (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_nat" "(JJ)J" nil nil)
+ (.visitCode)
+ ;; Test #1
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFLT $case-1)
+ ;; Test #2
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFGT $case-2)
+ ;; Case #3
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "divide" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
+ (.visitInsn Opcodes/LRETURN)
+ ;; Case #2
+ (.visitLabel $case-2)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitInsn Opcodes/LDIV)
+ (.visitInsn Opcodes/LRETURN)
+ ;; Case #1
+ (.visitLabel $case-1)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
+ (.visitJumpInsn Opcodes/IFLT $0)
+ ;; 1
+ (.visitLdcInsn (long 1))
+ (.visitInsn Opcodes/LRETURN)
+ ;; 0
+ (.visitLabel $0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LRETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323
+ _ (let [$test-2 (new Label)
+ $case-2 (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "rem_nat" "(JJ)J" nil nil)
+ (.visitCode)
+ ;; Test #1
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFLE $test-2)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFLE $test-2)
+ ;; Case #1
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitInsn Opcodes/LREM)
+ (.visitInsn Opcodes/LRETURN)
+ ;; Test #2
+ (.visitLabel $test-2)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_compareUnsigned" "(JJ)I")
+ (.visitJumpInsn Opcodes/IFLT $case-2)
+ ;; Case #3
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
+ (.visitVarInsn Opcodes/LLOAD 2)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "remainder" "(Ljava/math/BigInteger;)Ljava/math/BigInteger;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/math/BigInteger" "longValue" "()J")
+ (.visitInsn Opcodes/LRETURN)
+ ;; Case #2
+ (.visitLabel $case-2)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitInsn Opcodes/LRETURN)
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (.visitMaxs 0 0)
+ (.visitEnd)))]
+ nil)))
+
+(do-template [<name> <method> <class> <parse-method> <signature> <wrapper>]
+ (defn <name> [^ClassWriter =class]
+ (do (let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) <method> "(Ljava/lang/String;)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitTryCatchBlock $from $to $handler "java/lang/Exception")
+ (.visitLabel $from)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESTATIC <class> <parse-method> <signature>)
+ <wrapper>
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $to)
+ (.visitLabel $handler)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ nil))
+
+ ^:private compile-LuxRT-int-methods "decode_int" "java/lang/Long" "parseLong" "(Ljava/lang/String;)J" &&/wrap-long
+ ^:private compile-LuxRT-real-methods "decode_real" "java/lang/Double" "parseDouble" "(Ljava/lang/String;)D" &&/wrap-double
+ )
+
+(defn ^:private compile-LuxRT-pm-methods [^ClassWriter =class]
+ (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil)
+ (.visitCode)
+ (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn "Invalid expression for pattern-matching.")
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V")
+ (.visitInsn Opcodes/ATHROW)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (int 2))
+ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object")
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 0))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/AASTORE)
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int 1))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitInsn Opcodes/AASTORE)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_pop" "([Ljava/lang/Object;)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 0))
+ (.visitInsn Opcodes/AALOAD)
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn (int 1))
+ (.visitInsn Opcodes/AALOAD)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]
+ nil))
+
+(defn ^:private compile-LuxRT-text-methods [^ClassWriter =class]
+ (do (let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)
+ $end (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_clip" "(Ljava/lang/String;II)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException")
+ (.visitLabel $from)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitVarInsn Opcodes/ILOAD 2)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;")
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitJumpInsn Opcodes/GOTO $end)
+ (.visitLabel $to)
+ (.visitLabel $handler)
+ (.visitInsn Opcodes/POP)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitLabel $end)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ (let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitTryCatchBlock $from $to $handler "java/lang/IndexOutOfBoundsException")
+ (.visitLabel $from)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ILOAD 1)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C")
+ &&/wrap-char
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $to)
+ (.visitLabel $handler)
+ (.visitInsn Opcodes/POP)
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ nil))
+
+(defn ^:private compile-LuxRT-process-methods [^ClassWriter =class]
+ (do (doto (.visitField =class
+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)
+ "concurrency_level" "I" nil nil)
+ (.visitEnd))
+ (doto (.visitField =class
+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)
+ "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;" nil nil)
+ (.visitEnd))
+ (doto (.visitMethod =class Opcodes/ACC_STATIC "<clinit>" "()V" nil nil)
+ (.visitCode)
+ ;; concurrency_level
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Runtime" "getRuntime" "()Ljava/lang/Runtime;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Runtime" "availableProcessors" "()I")
+ (.visitFieldInsn Opcodes/PUTSTATIC "lux/LuxRT" "concurrency_level" "I")
+ ;; executor
+ (.visitTypeInsn Opcodes/NEW "java/util/concurrent/ScheduledThreadPoolExecutor")
+ (.visitInsn Opcodes/DUP)
+ (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "concurrency_level" "I")
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/ScheduledThreadPoolExecutor" "<init>" "(I)V")
+ (.visitFieldInsn Opcodes/PUTSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;")
+ ;; DONE
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "future" "(Llux/Function;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitTypeInsn Opcodes/NEW "java/lang/Thread")
+ (.visitInsn Opcodes/DUP)
+ (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable")
+ (.visitInsn Opcodes/DUP)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "<init>" "(Llux/Function;)V")
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Thread" "<init>" "(Ljava/lang/Runnable;)V")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Thread" "start" "()V")
+ (.visitLdcInsn &/unit-tag)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ (let [$immediately (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "schedule" "(JLlux/Function;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitLdcInsn (long 0))
+ (.visitInsn Opcodes/LCMP)
+ (.visitJumpInsn Opcodes/IFEQ $immediately)
+ ;; Schedule for later
+ (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;")
+ (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable")
+ (.visitInsn Opcodes/DUP)
+ (.visitVarInsn Opcodes/ALOAD 2)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "<init>" "(Llux/Function;)V")
+ (.visitVarInsn Opcodes/LLOAD 0)
+ (.visitFieldInsn Opcodes/GETSTATIC "java/util/concurrent/TimeUnit" "MILLISECONDS" "Ljava/util/concurrent/TimeUnit;")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/util/concurrent/ScheduledThreadPoolExecutor" "schedule" "(Ljava/lang/Runnable;JLjava/util/concurrent/TimeUnit;)Ljava/util/concurrent/ScheduledFuture;")
+ (.visitLdcInsn &/unit-tag)
+ (.visitInsn Opcodes/ARETURN)
+ ;; Run immediately
+ (.visitLabel $immediately)
+ (.visitFieldInsn Opcodes/GETSTATIC "lux/LuxRT" "executor" "Ljava/util/concurrent/ScheduledThreadPoolExecutor;")
+ (.visitTypeInsn Opcodes/NEW "lux/LuxRunnable")
+ (.visitInsn Opcodes/DUP)
+ (.visitVarInsn Opcodes/ALOAD 2)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "lux/LuxRunnable" "<init>" "(Llux/Function;)V")
+ (.visitMethodInsn Opcodes/INVOKEINTERFACE "java/util/concurrent/Executor" "execute" "(Ljava/lang/Runnable;)V")
+ (.visitLdcInsn &/unit-tag)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ nil))
+
+(def compile-LuxRT-class
+ (|do [_ (return nil)
+ :let [full-name &&/lux-utils-class
+ super-class (&host-generics/->bytecode-class-name "java.lang.Object")
+ tag-sig (&host-generics/->type-signature "java.lang.String")
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ full-name nil super-class (into-array String [])))
+ =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag)
+ (.visitEnd))
+ =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
+ (.visitLdcInsn "LOG: ")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V")
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V")
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; I
+ (.visitInsn Opcodes/ACONST_NULL) ;; I?
+ (.visitLdcInsn &/unit-tag) ;; I?U
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitLdcInsn (->> #'&/$Some meta ::&/idx int)) ;; I
+ (.visitLdcInsn "") ;; I?
+ (.visitVarInsn Opcodes/ALOAD 0) ;; I?O
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitLdcInsn "_")
+ (.visitLdcInsn "")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ _ (let [$from (new Label)
+ $to (new Label)
+ $handler (new Label)]
+ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" "(Llux/Function;)[Ljava/lang/Object;" nil nil)
+ (.visitCode)
+ (.visitTryCatchBlock $from $to $handler "java/lang/Throwable")
+ (.visitLabel $from)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "lux/Function" &&/apply-method (&&/apply-signature 1))
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;")
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitLabel $to)
+ (.visitLabel $handler) ;; T
+ (.visitLdcInsn (->> #'&/$None meta ::&/idx int)) ;; TI
+ (.visitInsn Opcodes/ACONST_NULL) ;; TI?
+ swap2x1 ;; I?T
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;") ;; I?S
+ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd)))
+ _ (doto =class
+ (compile-LuxRT-pm-methods)
+ (compile-LuxRT-adt-methods)
+ (compile-LuxRT-nat-methods)
+ (compile-LuxRT-int-methods)
+ (compile-LuxRT-deg-methods)
+ (compile-LuxRT-real-methods)
+ (compile-LuxRT-text-methods)
+ (compile-LuxRT-process-methods))]]
+ (&&/save-class! (second (string/split &&/lux-utils-class #"/"))
+ (.toByteArray (doto =class .visitEnd)))))
diff --git a/luxc/src/lux/compiler/module.clj b/luxc/src/lux/compiler/module.clj
deleted file mode 100644
index 9ca4e040b..000000000
--- a/luxc/src/lux/compiler/module.clj
+++ /dev/null
@@ -1,23 +0,0 @@
-(ns lux.compiler.module
- (: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])
- [lux.analyser.module :as &module]))
-
-;; [Exports]
-(def tag-groups
- "(Lux (List (, Text (List Text))))"
- (|do [module &/get-current-module]
- (return (&/|map (fn [pair]
- (|case pair
- [name [tags exported? _]]
- (&/T [name (&/|map (fn [tag]
- (|let [[t-prefix t-name] tag]
- t-name))
- tags)])))
- (&/get$ &module/$types module)))
- ))
diff --git a/luxc/src/lux/lexer.clj b/luxc/src/lux/lexer.clj
index 38fa15cd0..2f9c0717e 100644
--- a/luxc/src/lux/lexer.clj
+++ b/luxc/src/lux/lexer.clj
@@ -30,6 +30,7 @@
(defn ^:private escape-char [escaped]
"(-> Text (Lux Text))"
(cond (.equals ^Object escaped "\\t") (return "\t")
+ (.equals ^Object escaped "\\v") (return "\u000B")
(.equals ^Object escaped "\\b") (return "\b")
(.equals ^Object escaped "\\n") (return "\n")
(.equals ^Object escaped "\\r") (return "\r")
@@ -42,6 +43,7 @@
(defn ^:private escape-char* [escaped]
"(-> Text Text)"
(cond (.equals ^Object escaped "\\t") "\t"
+ (.equals ^Object escaped "\\v") "\u000B"
(.equals ^Object escaped "\\b") "\b"
(.equals ^Object escaped "\\n") "\n"
(.equals ^Object escaped "\\r") "\r"
@@ -63,6 +65,8 @@
(case (.charAt raw-line (+ 1 idx))
\t (do (.append buffer "\t")
(recur (+ 2 idx)))
+ \v (do (.append buffer "\u000B")
+ (recur (+ 2 idx)))
\b (do (.append buffer "\b")
(recur (+ 2 idx)))
\n (do (.append buffer "\n")
diff --git a/luxc/src/lux/repl.clj b/luxc/src/lux/repl.clj
index 22c2f47d2..974267486 100644
--- a/luxc/src/lux/repl.clj
+++ b/luxc/src/lux/repl.clj
@@ -7,9 +7,9 @@
[optimizer :as &optimizer]
[compiler :as &compiler])
[lux.compiler.cache :as &cache]
- [lux.analyser.base :as &a-base]
- [lux.analyser.lux :as &a-lux]
- [lux.analyser.module :as &module])
+ (lux.analyser [base :as &a-base]
+ [lux :as &a-lux]
+ [module :as &module]))
(:import (java.io InputStreamReader
BufferedReader)))
diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj
index cebe60d9c..dd2e536bb 100644
--- a/luxc/src/lux/type.clj
+++ b/luxc/src/lux/type.clj
@@ -23,20 +23,33 @@
(def empty-env &/$Nil)
-(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil)))
+(def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "#Bool" &/$Nil)))
(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil)))
(def Deg (&/$NamedT (&/T ["lux" "Deg"]) (&/$HostT &&host/deg-data-tag &/$Nil)))
-(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil)))
-(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil)))
-(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil)))
-(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil)))
+(def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "#Int" &/$Nil)))
+(def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "#Real" &/$Nil)))
+(def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "#Char" &/$Nil)))
+(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "#Text" &/$Nil)))
(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text)))
+(do-template [<name> <tag>]
+ (defn <name> [elem-type]
+ (&/$HostT <tag> (&/|list elem-type)))
+
+ Array "#Array"
+ Atom "#Atom"
+ )
+
(def Bottom
(&/$NamedT (&/T ["lux" "Bottom"])
(&/$UnivQ empty-env
(&/$BoundT 1))))
+(def Top
+ (&/$NamedT (&/T ["lux" "Top"])
+ (&/$ExQ empty-env
+ (&/$BoundT 1))))
+
(def IO
(&/$NamedT (&/T ["lux/codata" "IO"])
(&/$UnivQ empty-env
@@ -230,6 +243,14 @@
;; [Exports]
;; Type vars
+(def reset-mappings
+ (fn [state]
+ (return* (&/update$ &/$type-vars #(->> %
+ ;; (&/set$ &/$counter 0)
+ (&/set$ &/$mappings (&/|table)))
+ state)
+ nil)))
+
(def create-var
(fn [state]
(let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))]
@@ -254,7 +275,7 @@
(fn [state]
((|do [mappings* (&/map% (fn [binding]
(|let [[?id ?type] binding]
- (if (.equals ^Object id ?id)
+ (if (= id ?id)
(return binding)
(|case ?type
(&/$None)
@@ -263,7 +284,7 @@
(&/$Some ?type*)
(|case ?type*
(&/$VarT ?id*)
- (if (.equals ^Object id ?id*)
+ (if (= id ?id*)
(return (&/T [?id &/$None]))
(return binding))
@@ -287,7 +308,7 @@
(defn clean* [?tid type]
(|case type
(&/$VarT ?id)
- (if (.equals ^Object ?tid ?id)
+ (if (= ?tid ?id)
(|do [? (bound? ?id)]
(if ?
(deref ?id)
@@ -298,7 +319,7 @@
==type (clean* ?tid =type)]
(|case ==type
(&/$VarT =id)
- (if (.equals ^Object ?tid =id)
+ (if (= ?tid =id)
(|do [_ (unset-var ?id)]
(return type))
(|do [_ (reset-var ?id ==type)]
@@ -503,13 +524,13 @@
(type= xoutput youtput))
[(&/$VarT xid) (&/$VarT yid)]
- (.equals ^Object xid yid)
+ (= xid yid)
[(&/$BoundT xidx) (&/$BoundT yidx)]
(= xidx yidx)
[(&/$ExT xid) (&/$ExT yid)]
- (.equals ^Object xid yid)
+ (= xid yid)
[(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)]
(and (type= xlambda ylambda) (type= xparam yparam))
@@ -646,13 +667,13 @@
(def ^:private init-fixpoints &/$Nil)
-(defn ^:private check* [class-loader fixpoints invariant?? expected actual]
+(defn ^:private check* [fixpoints invariant?? expected actual]
(if (clojure.lang.Util/identical expected actual)
(return fixpoints)
(&/with-attempt
(|case [expected actual]
[(&/$VarT ?eid) (&/$VarT ?aid)]
- (if (.equals ^Object ?eid ?aid)
+ (if (= ?eid ?aid)
(return fixpoints)
(|do [ebound (fn [state]
(|case ((deref ?eid) state)
@@ -674,13 +695,13 @@
(return fixpoints))
[(&/$Some etype) (&/$None _)]
- (check* class-loader fixpoints invariant?? etype actual)
+ (check* fixpoints invariant?? etype actual)
[(&/$None _) (&/$Some atype)]
- (check* class-loader fixpoints invariant?? expected atype)
+ (check* fixpoints invariant?? expected atype)
[(&/$Some etype) (&/$Some atype)]
- (check* class-loader fixpoints invariant?? etype atype))))
+ (check* fixpoints invariant?? etype atype))))
[(&/$VarT ?id) _]
(fn [state]
@@ -690,7 +711,7 @@
(&/$Left _)
((|do [bound (deref ?id)]
- (check* class-loader fixpoints invariant?? bound actual))
+ (check* fixpoints invariant?? bound actual))
state)))
[_ (&/$VarT ?id)]
@@ -701,18 +722,18 @@
(&/$Left _)
((|do [bound (deref ?id)]
- (check* class-loader fixpoints invariant?? expected bound))
+ (check* fixpoints invariant?? expected bound))
state)))
[(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)]
(if (= eid aid)
- (check* class-loader fixpoints invariant?? eA aA)
+ (check* fixpoints invariant?? eA aA)
(check-error "" expected actual))
[(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)]
(fn [state]
(|case ((|do [F1 (deref ?id)]
- (check* class-loader fixpoints invariant?? (&/$AppT F1 A1) actual))
+ (check* fixpoints invariant?? (&/$AppT F1 A1) actual))
state)
(&/$Right state* output)
(return* state* output)
@@ -721,46 +742,46 @@
(|case F2
(&/$UnivQ (&/$Cons _) _)
((|do [actual* (apply-type F2 A2)]
- (check* class-loader fixpoints invariant?? expected actual*))
+ (check* fixpoints invariant?? expected actual*))
state)
(&/$ExT _)
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)]
- (check* class-loader fixpoints* invariant?? A1 A2))
+ ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2)]
+ (check* fixpoints* invariant?? A1 A2))
state)
_
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? (&/$VarT ?id) F2)
+ ((|do [fixpoints* (check* fixpoints invariant?? (&/$VarT ?id) F2)
e* (apply-type F2 A1)
a* (apply-type F2 A2)]
- (check* class-loader fixpoints* invariant?? e* a*))
+ (check* fixpoints* invariant?? e* a*))
state))))
[(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)]
(fn [state]
(|case ((|do [F2 (deref ?id)]
- (check* class-loader fixpoints invariant?? expected (&/$AppT F2 A2)))
+ (check* fixpoints invariant?? expected (&/$AppT F2 A2)))
state)
(&/$Right state* output)
(return* state* output)
(&/$Left _)
- ((|do [fixpoints* (check* class-loader fixpoints invariant?? F1 (&/$VarT ?id))
+ ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$VarT ?id))
e* (apply-type F1 A1)
a* (apply-type F1 A2)]
- (check* class-loader fixpoints* invariant?? e* a*))
+ (check* fixpoints* invariant?? e* a*))
state)))
[(&/$AppT F A) _]
(let [fp-pair (&/T [expected actual])
- _ (when (> (&/|length fixpoints) 40)
- (println 'FIXPOINTS (->> (&/|keys fixpoints)
- (&/|map (fn [pair]
- (|let [[e a] pair]
- (str (show-type e) ":+:"
- (show-type a)))))
- (&/|interpose "\n\n")
- (&/fold str "")))
+ _ (when (> (&/|length fixpoints) 64)
+ (&/|log! (println-str 'FIXPOINTS (->> (&/|keys fixpoints)
+ (&/|map (fn [pair]
+ (|let [[e a] pair]
+ (str (show-type e) ":+:"
+ (show-type a)))))
+ (&/|interpose "\n\n")
+ (&/fold str ""))))
(assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))]
(|case (fp-get fp-pair fixpoints)
(&/$Some ?)
@@ -770,25 +791,25 @@
(&/$None)
(|do [expected* (apply-type F A)]
- (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual))))
+ (check* (fp-put fp-pair true fixpoints) invariant?? expected* actual))))
[_ (&/$AppT (&/$ExT aid) A)]
(check-error "" expected actual)
[_ (&/$AppT F A)]
(|do [actual* (apply-type F A)]
- (check* class-loader fixpoints invariant?? expected actual*))
+ (check* fixpoints invariant?? expected actual*))
[(&/$UnivQ _) _]
(|do [$arg existential
expected* (apply-type expected $arg)]
- (check* class-loader fixpoints invariant?? expected* actual))
+ (check* fixpoints invariant?? expected* actual))
[_ (&/$UnivQ _)]
(with-var
(fn [$arg]
(|do [actual* (apply-type actual $arg)
- =output (check* class-loader fixpoints invariant?? expected actual*)
+ =output (check* fixpoints invariant?? expected actual*)
_ (clean $arg expected)]
(return =output))))
@@ -796,24 +817,34 @@
(with-var
(fn [$arg]
(|do [expected* (apply-type expected $arg)
- =output (check* class-loader fixpoints invariant?? expected* actual)
+ =output (check* fixpoints invariant?? expected* actual)
_ (clean $arg actual)]
(return =output))))
[_ (&/$ExQ a!env a!def)]
(|do [$arg existential
actual* (apply-type actual $arg)]
- (check* class-loader fixpoints invariant?? expected actual*))
+ (check* fixpoints invariant?? expected actual*))
[(&/$HostT e!data) (&/$HostT a!data)]
- (&&host/check-host-types (partial check* class-loader fixpoints true)
- check-error
- fixpoints
- existential
- class-loader
- invariant??
- e!data
- a!data)
+ (|do [? &/jvm?]
+ (if ?
+ (|do [class-loader &/loader]
+ (&&host/check-host-types (partial check* fixpoints true)
+ check-error
+ fixpoints
+ existential
+ class-loader
+ invariant??
+ e!data
+ a!data))
+ (|let [[e!name e!params] e!data
+ [a!name a!params] a!data]
+ (if (and (= e!name a!name)
+ (= (&/|length e!params) (&/|length a!params)))
+ (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)]
+ (return fixpoints))
+ (check-error "" expected actual)))))
[(&/$VoidT) (&/$VoidT)]
(return fixpoints)
@@ -822,27 +853,27 @@
(return fixpoints)
[(&/$LambdaT eI eO) (&/$LambdaT aI aO)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? aI eI)]
- (check* class-loader fixpoints* invariant?? eO aO))
+ (|do [fixpoints* (check* fixpoints invariant?? aI eI)]
+ (check* fixpoints* invariant?? eO aO))
[(&/$ProdT eL eR) (&/$ProdT aL aR)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)]
- (check* class-loader fixpoints* invariant?? eR aR))
+ (|do [fixpoints* (check* fixpoints invariant?? eL aL)]
+ (check* fixpoints* invariant?? eR aR))
[(&/$SumT eL eR) (&/$SumT aL aR)]
- (|do [fixpoints* (check* class-loader fixpoints invariant?? eL aL)]
- (check* class-loader fixpoints* invariant?? eR aR))
+ (|do [fixpoints* (check* fixpoints invariant?? eL aL)]
+ (check* fixpoints* invariant?? eR aR))
[(&/$ExT e!id) (&/$ExT a!id)]
- (if (.equals ^Object e!id a!id)
+ (if (= e!id a!id)
(return fixpoints)
(check-error "" expected actual))
[(&/$NamedT _ ?etype) _]
- (check* class-loader fixpoints invariant?? ?etype actual)
+ (check* fixpoints invariant?? ?etype actual)
[_ (&/$NamedT _ ?atype)]
- (check* class-loader fixpoints invariant?? expected ?atype)
+ (check* fixpoints invariant?? expected ?atype)
[_ _]
(&/fail ""))
@@ -850,8 +881,7 @@
(check-error err expected actual)))))
(defn check [expected actual]
- (|do [class-loader &/loader
- _ (check* class-loader init-fixpoints false expected actual)]
+ (|do [_ (check* init-fixpoints false expected actual)]
(return nil)))
(defn actual-type [type]
diff --git a/luxc/src/lux/type/host.clj b/luxc/src/lux/type/host.clj
index b255f97c5..40a3373f0 100644
--- a/luxc/src/lux/type/host.clj
+++ b/luxc/src/lux/type/host.clj
@@ -250,45 +250,43 @@
(defn primitive-type? [type-name]
(contains? primitive-types type-name)))
+(def ^:private lux-jvm-type-combos
+ #{#{"java.lang.Boolean" "#Bool"}
+ #{"java.lang.Long" "#Int"}
+ #{"java.lang.Double" "#Real"}
+ #{"java.lang.Character" "#Char"}
+ #{"java.lang.String" "#Text"}})
+
+(defn ^:private lux-type? [^String class-name]
+ (.startsWith class-name "#"))
+
(defn check-host-types [check check-error fixpoints existential class-loader invariant?? expected actual]
- (|let [[e!name e!params] expected
- [a!name a!params] actual]
- ;; TODO: Delete first branch. It smells like a hack...
- (try (cond (or (= "java.lang.Object" e!name)
- (and (= nat-data-tag e!name)
- (= nat-data-tag a!name))
- (and (= deg-data-tag e!name)
- (= deg-data-tag a!name))
- (and (= null-data-tag e!name)
- (= null-data-tag a!name))
- (and (not (primitive-type? e!name))
- (= null-data-tag a!name)))
- (return fixpoints)
-
- (or (and (= array-data-tag e!name)
- (not= array-data-tag a!name))
- (= nat-data-tag e!name) (= nat-data-tag a!name)
- (= deg-data-tag e!name) (= deg-data-tag a!name)
- (= null-data-tag e!name) (= null-data-tag a!name))
- (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))
-
- :else
- (let [e!name (as-obj e!name)
- a!name (as-obj a!name)]
- (cond (= e!name a!name)
- (if (= (&/|length e!params) (&/|length a!params))
- (|do [_ (&/map2% check e!params a!params)]
- (return fixpoints))
- (&/fail-with-loc (str "[Type Error] Amounts of generic parameters don't match: " e!name "(" (&/|length e!params) ")" " vs " a!name "(" (&/|length a!params) ")")))
-
- (not invariant??)
- (|do [actual* (->super-type existential class-loader e!name a!name a!params)]
- (check (&/$HostT e!name e!params) actual*))
-
- :else
- (&/fail-with-loc (str "[Type Error] Names don't match: " e!name " =/= " a!name)))))
+ (|let [[^String e!name e!params] expected
+ [^String a!name a!params] actual]
+ (try (let [e!name (as-obj e!name)
+ a!name (as-obj a!name)]
+ (cond (= e!name a!name)
+ (if (= (&/|length e!params) (&/|length a!params))
+ (|do [_ (&/map2% check e!params a!params)]
+ (return fixpoints))
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)))
+
+ (or (lux-type? e!name)
+ (lux-type? a!name))
+ (if (or (= "java.lang.Object" e!name)
+ (contains? lux-jvm-type-combos #{e!name a!name})
+ (and (not (primitive-type? e!name))
+ (= null-data-tag a!name)))
+ (return fixpoints)
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)))
+
+ (not invariant??)
+ (|do [actual* (->super-type existential class-loader e!name a!name a!params)]
+ (check (&/$HostT e!name e!params) actual*))
+
+ :else
+ (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params))))
(catch Exception e
- (prn 'check-host-types e [e!name a!name])
(throw e)))))
(defn gtype->gclass [gtype]
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 520e55434..7ae8c2847 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -1,7 +1,7 @@
## Basic types
(_lux_def Bool
(+12 ["lux" "Bool"]
- (+0 "java.lang.Boolean" (+0)))
+ (+0 "#Bool" (+0)))
(+1 [["lux" "type?"] (+0 true)]
(+1 [["lux" "export?"] (+0 true)]
(+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill boolean values.")]
@@ -19,7 +19,7 @@
(_lux_def Int
(+12 ["lux" "Int"]
- (+0 "java.lang.Long" (+0)))
+ (+0 "#Int" (+0)))
(+1 [["lux" "type?"] (+0 true)]
(+1 [["lux" "export?"] (+0 true)]
(+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill integer numbers.")]
@@ -27,7 +27,7 @@
(_lux_def Real
(+12 ["lux" "Real"]
- (+0 "java.lang.Double" (+0)))
+ (+0 "#Real" (+0)))
(+1 [["lux" "type?"] (+0 true)]
(+1 [["lux" "export?"] (+0 true)]
(+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill floating-point numbers.")]
@@ -45,7 +45,7 @@
(_lux_def Char
(+12 ["lux" "Char"]
- (+0 "java.lang.Character" (+0)))
+ (+0 "#Char" (+0)))
(+1 [["lux" "type?"] (+0 true)]
(+1 [["lux" "export?"] (+0 true)]
(+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill character values.")]
@@ -53,7 +53,7 @@
(_lux_def Text
(+12 ["lux" "Text"]
- (+0 "java.lang.String" (+0)))
+ (+0 "#Text" (+0)))
(+1 [["lux" "type?"] (+0 true)]
(+1 [["lux" "export?"] (+0 true)]
(+1 [["lux" "doc"] (+6 "Your standard, run-of-the-mill string values.")]
@@ -323,11 +323,11 @@
## (type: Cursor
## {#module Text
-## #line Int
-## #column Int})
+## #line Nat
+## #column Nat})
(_lux_def Cursor
(#NamedT ["lux" "Cursor"]
- (#ProdT Text (#ProdT Int Int)))
+ (#ProdT Text (#ProdT Nat Nat)))
(#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module")
(#Cons (#TextA "line")
(#Cons (#TextA "column")
@@ -485,6 +485,26 @@
Text])]))
default-def-meta-exported)
+## (type: Module-State
+## #Active
+## #Compiled
+## #Cached)
+(_lux_def Module-State
+ (#NamedT ["lux" "Module-State"]
+ (#SumT
+ ## #Active
+ Unit
+ (#SumT
+ ## #Compiled
+ Unit
+ ## #Cached
+ Unit)))
+ (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "Active")
+ (#Cons (#TextA "Compiled")
+ (#Cons (#TextA "Cached")
+ #Nil))))]
+ default-def-meta-exported))
+
## (type: Module
## {#module-hash Int
## #module-aliases (List [Text Text])
@@ -493,6 +513,7 @@
## #tags (List [Text [Nat (List Ident) Bool Type]])
## #types (List [Text [(List Ident) Bool Type]])}
## #module-anns Anns
+## #module-state Module-State
## )
(_lux_def Module
(#NamedT ["lux" "Module"]
@@ -518,8 +539,9 @@
(#ProdT (#AppT List Ident)
(#ProdT Bool
Type))))
- ## "lux;module-anns"
- Anns)
+ (#ProdT ## "lux;module-anns"
+ Anns
+ Module-State))
))))))
(#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module-hash")
(#Cons (#TextA "module-aliases")
@@ -528,7 +550,8 @@
(#Cons (#TextA "tags")
(#Cons (#TextA "types")
(#Cons (#TextA "module-anns")
- #Nil))))))))]
+ (#Cons (#TextA "module-state")
+ #Nil)))))))))]
(#Cons [["lux" "doc"] (#TextA "All the information contained within a Lux module.")]
default-def-meta-exported)))
@@ -556,21 +579,17 @@
default-def-meta-exported)))
## (type: Compiler-Info
-## {#compiler-name Text
-## #compiler-version Text
+## {#compiler-version Text
## #compiler-mode Compiler-Mode})
(_lux_def Compiler-Info
(#NamedT ["lux" "Compiler-Info"]
- (#ProdT ## "lux;compiler-name"
+ (#ProdT ## "lux;compiler-version"
Text
- (#ProdT ## "lux;compiler-version"
- Text
- ## "lux;compiler-mode"
- Compiler-Mode)))
- (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-name")
- (#Cons (#TextA "compiler-version")
- (#Cons (#TextA "compiler-mode")
- #Nil))))]
+ ## "lux;compiler-mode"
+ Compiler-Mode))
+ (#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "compiler-version")
+ (#Cons (#TextA "compiler-mode")
+ #Nil)))]
(#Cons [["lux" "doc"] (#TextA "Information about the current version and type of compiler that is running.")]
default-def-meta-exported)))
@@ -584,6 +603,7 @@
## #expected (Maybe Type)
## #seed Nat
## #scope-type-vars (List Nat)
+## #catching (List Text)
## #host Void})
(_lux_def Compiler
(#NamedT ["lux" "Compiler"]
@@ -604,10 +624,13 @@
(#AppT Maybe Type)
(#ProdT ## "lux;seed"
Nat
- (#ProdT ## "lux;scope-type-vars"
+ (#ProdT ## scope-type-vars
(#AppT List Nat)
## "lux;host"
- Void))))))))))
+ (#ProdT ## catching
+ (#AppT List Text)
+ ## "lux;host"
+ Void)))))))))))
(#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "info")
(#Cons (#TextA "source")
(#Cons (#TextA "cursor")
@@ -617,8 +640,9 @@
(#Cons (#TextA "expected")
(#Cons (#TextA "seed")
(#Cons (#TextA "scope-type-vars")
- (#Cons (#TextA "host")
- #Nil)))))))))))]
+ (#Cons (#TextA "catching")
+ (#Cons (#TextA "host")
+ #Nil))))))))))))]
(#Cons [["lux" "doc"] (#TextA "Represents the state of the Lux compiler during a run.
It is provided to macros during their invocation, so they can access compiler data.
@@ -649,16 +673,10 @@
default-def-meta-exported))
## Base functions & macros
-## (def: _cursor
-## Cursor
-## ["" -1 -1])
(_lux_def _cursor
- (_lux_: Cursor ["" -1 -1])
+ (_lux_: Cursor ["" +0 +0])
#Nil)
-## (def: (_meta data)
-## (-> (AST' (Meta Cursor)) AST)
-## [["" -1 -1] data])
(_lux_def _meta
(_lux_: (#LambdaT (#AppT AST'
(#AppT Meta Cursor))
@@ -667,11 +685,6 @@
[_cursor data]))
#Nil)
-## (def: (return x)
-## (All [a]
-## (-> a Compiler
-## (Either Text [Compiler a])))
-## ...)
(_lux_def return
(_lux_: (#UnivQ #Nil
(#LambdaT (#BoundT +1)
@@ -684,11 +697,6 @@
(#Right state val))))
#Nil)
-## (def: (fail msg)
-## (All [a]
-## (-> Text Compiler
-## (Either Text [Compiler a])))
-## ...)
(_lux_def fail
(_lux_: (#UnivQ #Nil
(#LambdaT Text
@@ -1020,7 +1028,7 @@
(def:'' (Text/= x y)
#Nil
(#LambdaT Text (#LambdaT Text Bool))
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y]))
+ (_lux_proc ["text" "="] [x y]))
(def:'' (get-rep key env)
#Nil
@@ -1133,7 +1141,7 @@
#Nil
(#UnivQ #Nil
(#LambdaT ($' List (#BoundT +1)) Int))
- (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list))
+ (fold (lambda'' [_ acc] (_lux_proc ["int" "+"] [1 acc])) 0 list))
(macro:' #export (All tokens)
(#Cons [["lux" "doc"] (#TextA "## Universal quantification.
@@ -1445,7 +1453,7 @@
(def:''' (wrap-meta content)
#Nil
(-> AST AST)
- (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1)))
+ (tuple$ (list (tuple$ (list (text$ "") (nat$ +0) (nat$ +0)))
content)))
(def:''' (untemplate-list tokens)
@@ -1658,10 +1666,17 @@
(#Cons [[k' v] dict'])
(#Cons [[k' v'] (put k v dict')]))))
+(def:''' #export (log! message)
+ (list [["lux" "doc"] (#TextA "Logs message to standard output.
+
+ Useful for debugging.")])
+ (-> Text Unit)
+ (_lux_proc ["io" "log"] [message]))
+
(def:''' (Text/append x y)
#Nil
(-> Text Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y]))
+ (_lux_proc ["text" "append"] [x y]))
(def:''' (Ident/encode ident)
#Nil
@@ -1695,9 +1710,9 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars} state]
+ #scope-type-vars scope-type-vars #catching _} state]
(_lux_case (get module modules)
- (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _})
+ (#Some {#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _})
(_lux_case (get name defs)
(#Some [def-type def-meta def-value])
(_lux_case (get-meta ["lux" "alias"] def-meta)
@@ -1854,7 +1869,7 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars}
+ #scope-type-vars scope-type-vars #catching _}
(_lux_case (reverse scopes)
(#Cons {#name (#;Cons module-name #Nil) #inner-closures _ #locals _ #closure _} _)
(#Right [state module-name])
@@ -1907,12 +1922,12 @@
(macro:' #export (|> tokens)
(list [["lux" "doc"] (#TextA "## Piping macro.
- (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\"))
+ (|> elems (map Int/encode) (interpose \" \") (fold Text/append \"\"))
## =>
(fold Text/append \"\"
(interpose \" \"
- (map ->Text elems)))")])
+ (map Int/encode elems)))")])
(_lux_case tokens
(#Cons [init apps])
(return (list (fold (_lux_: (-> AST AST AST)
@@ -1934,12 +1949,12 @@
(macro:' #export (<| tokens)
(list [["lux" "doc"] (#TextA "## Reverse piping macro.
- (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems)
+ (<| (fold Text/append \"\") (interpose \" \") (map Int/encode) elems)
## =>
(fold Text/append \"\"
(interpose \" \"
- (map ->Text elems)))")])
+ (map Int/encode elems)))")])
(_lux_case (reverse tokens)
(#Cons [init apps])
(return (list (fold (_lux_: (-> AST AST AST)
@@ -2053,12 +2068,47 @@
(def:''' (i= x y)
#Nil
(-> Int Int Bool)
- (_lux_proc ["jvm" "leq"] [x y]))
+ (_lux_proc ["int" "="] [x y]))
+
+(def:''' (Bool/encode x)
+ #Nil
+ (-> Bool Text)
+ (if x "true" "false"))
+
+(def:''' (Nat/encode x)
+ #Nil
+ (-> Nat Text)
+ (_lux_proc ["nat" "encode"] [x]))
+
+(def:''' (Int/encode x)
+ #Nil
+ (-> Int Text)
+ (_lux_proc ["int" "encode"] [x]))
+
+(def:''' (Deg/encode x)
+ #Nil
+ (-> Deg Text)
+ (_lux_proc ["deg" "encode"] [x]))
-(def:''' (->Text x)
+(def:''' (Real/encode x)
#Nil
- (-> (host java.lang.Object) Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))
+ (-> Real Text)
+ (_lux_proc ["real" "encode"] [x]))
+
+(def:''' (Char/encode x)
+ #Nil
+ (-> Char Text)
+ (let' [as-text (_lux_case x
+ #"\t" "\\t"
+ #"\v" "\\v"
+ #"\b" "\\b"
+ #"\n" "\\n"
+ #"\r" "\\r"
+ #"\f" "\\f"
+ #"\"" "\\\""
+ #"\\" "\\\\"
+ _ (_lux_proc ["char" "to-text"] [x]))]
+ ($_ Text/append "#\"" as-text "\"")))
(macro:' #export (do-template tokens)
(list [["lux" "doc"] (#TextA "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary.
@@ -2081,7 +2131,7 @@
(|> data'
(join-map (. apply (make-env bindings')))
return)
- (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings)))))
+ (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (Int/encode num-bindings)))))
_
(fail "Wrong syntax for do-template"))
@@ -2089,47 +2139,47 @@
_
(fail "Wrong syntax for do-template")))
-(do-template [<type> <category> <=-name> <=> <lt-name> <lte-name> <lt> <gt-name> <gte-name>
+(do-template [<type> <category> <=-name> <lt-name> <lte-name> <gt-name> <gte-name>
<eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>]
[(def:''' #export (<=-name> test subject)
(list [["lux" "doc"] (#TextA <eq-doc>)])
(-> <type> <type> Bool)
- (_lux_proc [<category> <=>] [subject test]))
+ (_lux_proc [<category> "="] [subject test]))
(def:''' #export (<lt-name> test subject)
(list [["lux" "doc"] (#TextA <<-doc>)])
(-> <type> <type> Bool)
- (_lux_proc [<category> <lt>] [subject test]))
+ (_lux_proc [<category> "<"] [subject test]))
(def:''' #export (<lte-name> test subject)
(list [["lux" "doc"] (#TextA <<=-doc>)])
(-> <type> <type> Bool)
- (if (_lux_proc [<category> <lt>] [subject test])
+ (if (_lux_proc [<category> "<"] [subject test])
true
- (_lux_proc [<category> <=>] [subject test])))
+ (_lux_proc [<category> "="] [subject test])))
(def:''' #export (<gt-name> test subject)
(list [["lux" "doc"] (#TextA <>-doc>)])
(-> <type> <type> Bool)
- (_lux_proc [<category> <lt>] [test subject]))
+ (_lux_proc [<category> "<"] [test subject]))
(def:''' #export (<gte-name> test subject)
(list [["lux" "doc"] (#TextA <>=-doc>)])
(-> <type> <type> Bool)
- (if (_lux_proc [<category> <lt>] [test subject])
+ (if (_lux_proc [<category> "<"] [test subject])
true
- (_lux_proc [<category> <=>] [subject test])))]
+ (_lux_proc [<category> "="] [subject test])))]
- [ Nat "nat" n.= "=" n.< n.<= "<" n.> n.>=
+ [ Nat "nat" n.= n.< n.<= n.> n.>=
"Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."]
- [ Int "jvm" i.= "leq" i.< i.<= "llt" i.> i.>=
+ [ Int "int" i.= i.< i.<= i.> i.>=
"Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."]
- [Deg "deg" d.= "=" d.< d.<= "<" d.> d.>=
+ [ Deg "deg" d.= d.< d.<= d.> d.>=
"Degree equality." "Degree less-than." "Degree less-than-equal." "Degree greater-than." "Degree greater-than-equal."]
- [Real "jvm" r.= "deq" r.< r.<= "dlt" r.> r.>=
+ [Real "real" r.= r.< r.<= r.> r.>=
"Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."]
)
@@ -2139,29 +2189,29 @@
(-> <type> <type> <type>)
(_lux_proc <op> [subject param]))]
- [ Nat n.+ ["nat" "+"] "Nat(ural) addition."]
- [ Nat n.- ["nat" "-"] "Nat(ural) substraction."]
- [ Nat n.* ["nat" "*"] "Nat(ural) multiplication."]
- [ Nat n./ ["nat" "/"] "Nat(ural) division."]
- [ Nat n.% ["nat" "%"] "Nat(ural) remainder."]
+ [ Nat n.+ [ "nat" "+"] "Nat(ural) addition."]
+ [ Nat n.- [ "nat" "-"] "Nat(ural) substraction."]
+ [ Nat n.* [ "nat" "*"] "Nat(ural) multiplication."]
+ [ Nat n./ [ "nat" "/"] "Nat(ural) division."]
+ [ Nat n.% [ "nat" "%"] "Nat(ural) remainder."]
- [ Int i.+ ["jvm" "ladd"] "Int(eger) addition."]
- [ Int i.- ["jvm" "lsub"] "Int(eger) substraction."]
- [ Int i.* ["jvm" "lmul"] "Int(eger) multiplication."]
- [ Int i./ ["jvm" "ldiv"] "Int(eger) division."]
- [ Int i.% ["jvm" "lrem"] "Int(eger) remainder."]
-
- [Deg d.+ ["deg" "+"] "Deg(ree) addition."]
- [Deg d.- ["deg" "-"] "Deg(ree) substraction."]
- [Deg d.* ["deg" "*"] "Deg(ree) multiplication."]
- [Deg d./ ["deg" "/"] "Deg(ree) division."]
- [Deg d.% ["deg" "%"] "Deg(ree) remainder."]
+ [ Int i.+ [ "int" "+"] "Int(eger) addition."]
+ [ Int i.- [ "int" "-"] "Int(eger) substraction."]
+ [ Int i.* [ "int" "*"] "Int(eger) multiplication."]
+ [ Int i./ [ "int" "/"] "Int(eger) division."]
+ [ Int i.% [ "int" "%"] "Int(eger) remainder."]
+
+ [ Deg d.+ [ "deg" "+"] "Deg(ree) addition."]
+ [ Deg d.- [ "deg" "-"] "Deg(ree) substraction."]
+ [ Deg d.* [ "deg" "*"] "Deg(ree) multiplication."]
+ [ Deg d./ [ "deg" "/"] "Deg(ree) division."]
+ [ Deg d.% [ "deg" "%"] "Deg(ree) remainder."]
- [Real r.+ ["jvm" "dadd"] "Real addition."]
- [Real r.- ["jvm" "dsub"] "Real substraction."]
- [Real r.* ["jvm" "dmul"] "Real multiplication."]
- [Real r./ ["jvm" "ddiv"] "Real division."]
- [Real r.% ["jvm" "drem"] "Real remainder."]
+ [Real r.+ ["real" "+"] "Real addition."]
+ [Real r.- ["real" "-"] "Real substraction."]
+ [Real r.* ["real" "*"] "Real multiplication."]
+ [Real r./ ["real" "/"] "Real division."]
+ [Real r.% ["real" "%"] "Real remainder."]
)
(do-template [<name> <type> <test> <doc>]
@@ -2172,14 +2222,14 @@
left
right))]
- [n.min Nat n.< "Nat(ural) minimum."]
- [n.max Nat n.> "Nat(ural) maximum."]
+ [n.min Nat n.< "Nat(ural) minimum."]
+ [n.max Nat n.> "Nat(ural) maximum."]
- [i.min Int i.< "Int(eger) minimum."]
- [i.max Int i.> "Int(eger) maximum."]
+ [i.min Int i.< "Int(eger) minimum."]
+ [i.max Int i.> "Int(eger) maximum."]
- [d.min Deg d.< "Deg(ree) minimum."]
- [d.max Deg d.> "Deg(ree) maximum."]
+ [d.min Deg d.< "Deg(ree) minimum."]
+ [d.max Deg d.> "Deg(ree) maximum."]
[r.min Real r.< "Real minimum."]
[r.max Real r.> "Real minimum."]
@@ -2206,7 +2256,7 @@
($' Maybe Macro))
(do Monad<Maybe>
[$module (get module modules)
- gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} (_lux_: Module $module)]
+ gdef (let' [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} (_lux_: Module $module)]
(get name bindings))]
(let' [[def-type def-meta def-value] (_lux_: Def gdef)]
(_lux_case (get-meta ["lux" "macro?"] def-meta)
@@ -2254,7 +2304,7 @@
#scopes scopes #type-vars types #host host
#seed seed #expected expected
#cursor cursor
- #scope-type-vars scope-type-vars}
+ #scope-type-vars scope-type-vars #catching _}
(#Right state (find-macro' modules current-module module name)))))))
(def:''' (macro? ident)
@@ -2506,20 +2556,20 @@
(-> Text ($' Lux AST))
(_lux_case state
{#info info #source source #modules modules
- #scopes scopes #type-vars types #host host
+ #scopes scopes #type-vars types #host host
#seed seed #expected expected
#cursor cursor
- #scope-type-vars scope-type-vars}
+ #scope-type-vars scope-type-vars #catching catching}
(#Right {#info info #source source #modules modules
- #scopes scopes #type-vars types #host host
+ #scopes scopes #type-vars types #host host
#seed (n.+ +1 seed) #expected expected
#cursor cursor
- #scope-type-vars scope-type-vars}
- (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))]))))
+ #scope-type-vars scope-type-vars #catching catching}
+ (symbol$ ["" ($_ Text/append "__gensym__" prefix (Nat/encode seed))]))))
(macro:' #export (Rec tokens)
(list [["lux" "doc"] (#TextA "## Parameter-less recursive types.
- ## A name has to be given to the whole type, to use it within it's body.
+ ## A name has to be given to the whole type, to use it within its body.
(Rec Self
[Int (List Self)])")])
(_lux_case tokens
@@ -2598,36 +2648,26 @@
(let' [[left right] pair]
(list left right)))
-(def:''' (Nat->Text x)
- #Nil
- (-> Nat Text)
- (_lux_proc ["nat" "encode"] [x]))
-
-(def:''' (Deg->Text x)
- #Nil
- (-> Deg Text)
- (_lux_proc ["deg" "encode"] [x]))
-
(def:' (ast-to-text ast)
(-> AST Text)
(_lux_case ast
[_ (#BoolS value)]
- (->Text value)
+ (Bool/encode value)
[_ (#NatS value)]
- (Nat->Text value)
+ (Nat/encode value)
[_ (#IntS value)]
- (->Text value)
+ (Int/encode value)
[_ (#DegS value)]
- (Deg->Text value)
+ (Deg/encode value)
[_ (#RealS value)]
- (->Text value)
+ (Real/encode value)
[_ (#CharS value)]
- ($_ Text/append "#" "\"" (->Text value) "\"")
+ ($_ Text/append "#" "\"" (Char/encode value) "\"")
[_ (#TextS value)]
($_ Text/append "\"" value "\"")
@@ -2966,14 +3006,6 @@
(#;Some (#;Right []))
(list (' #hidden))))
-(def:''' #export (log! message)
- (list [["lux" "doc"] (#TextA "Logs message to standard output.
-
- Useful for debugging.")])
- (-> Text Unit)
- (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"]
- [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message]))
-
(macro:' #export (def: tokens)
(list [["lux" "doc"] (#TextA "## Defines global constants/functions.
(def: (rejoin-pair pair)
@@ -3191,43 +3223,83 @@
(#Some y)
(#Some y))))
-(def: (last-index-of part text)
- (-> Text Text Int)
- (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:lastIndexOf:java.lang.String"] [text part])]))
+(do-template [<name> <proc> <start>]
+ [(def: (<name> part text)
+ (-> Text Text (Maybe Nat))
+ (_lux_proc ["text" <proc>] [text part <start>]))]
+
+ [index-of "index" +0]
+ [last-index-of "last-index" (_lux_proc ["text" "size"] [text])]
+ )
+
+(def: (clip1 from text)
+ (-> Nat Text (Maybe Text))
+ (_lux_proc ["text" "clip"] [text from (_lux_proc ["text" "size"] [text])]))
+
+(def: (clip2 from to text)
+ (-> Nat Nat Text (Maybe Text))
+ (_lux_proc ["text" "clip"] [text from to]))
+
+(def: #export (error! message)
+ {#;doc "## Causes an error, with the given error message.
+ (error! \"OH NO!\")"}
+ (-> Text Bottom)
+ (_lux_proc ["io" "error"] [message]))
+
+(macro: #export (default tokens state)
+ {#;doc "## Allows you to provide a default value that will be used
+ ## if a (Maybe x) value turns out to be #;None.
+ (default 20 (#;Some 10)) => 10
-(def: (index-of part text)
- (-> Text Text Int)
- (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:indexOf:java.lang.String"] [text part])]))
+ (default 20 #;None) => 20"}
+ (case tokens
+ (^ (list else maybe))
+ (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])])
+ code (` (case (~ maybe)
+ (#;Some (~ g!temp))
+ (~ g!temp)
-(def: (substring1 idx text)
- (-> Int Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [text (_lux_proc ["jvm" "l2i"] [idx])]))
+ #;None
+ (~ else)))]
+ (#;Right [state (list code)]))
-(def: (substring2 idx1 idx2 text)
- (-> Int Int Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [text (_lux_proc ["jvm" "l2i"] [idx1]) (_lux_proc ["jvm" "l2i"] [idx2])]))
+ _
+ (#;Left "Wrong syntax for ?")))
(def: (split-text splitter input)
(-> Text Text (List Text))
- (let [idx (index-of splitter input)]
- (if (i.< 0 idx)
- (#Cons input #Nil)
- (#Cons (substring2 0 idx input)
- (split-text splitter (substring1 (i.+ 1 idx) input))))))
+ (case (index-of splitter input)
+ #;None
+ (#Cons input #Nil)
+
+ (#;Some idx)
+ (#Cons (default (error! "UNDEFINED")
+ (clip2 +0 idx input))
+ (split-text splitter
+ (default (error! "UNDEFINED")
+ (clip1 (n.+ +1 idx) input))))))
(def: (split-module-contexts module)
(-> Text (List Text))
- (#Cons module (let [idx (last-index-of "/" module)]
- (if (i.< 0 idx)
- #Nil
- (split-module-contexts (substring2 0 idx module))))))
+ (#Cons module (case (last-index-of "/" module)
+ #;None
+ #Nil
+
+ (#;Some idx)
+ (split-module-contexts (default (error! "UNDEFINED")
+ (clip2 +0 idx module))))))
(def: (split-module module)
(-> Text (List Text))
- (let [idx (index-of "/" module)]
- (if (i.< 0 idx)
- (list module)
- (list& (substring2 0 idx module) (split-module (substring1 (i.+ 1 idx) module))))))
+ (case (index-of "/" module)
+ #;None
+ (list module)
+
+ (#;Some idx)
+ (list& (default (error! "UNDEFINED")
+ (clip2 +0 idx module))
+ (split-module (default (error! "UNDEFINED")
+ (clip1 (n.+ +1 idx) module))))))
(def: (nth idx xs)
(All [a]
@@ -3356,7 +3428,7 @@
(let [{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars} state]
+ #scope-type-vars scope-type-vars #catching _} state]
(case (get name modules)
(#Some module)
(#Right state module)
@@ -3374,7 +3446,7 @@
(-> Ident (Lux [Nat (List Ident) Bool Type]))
(do Monad<Lux>
[=module (find-module module)
- #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _} =module]]
+ #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags-table #types types #module-anns _ #module-state _} =module]]
(case (get name tags-table)
(#Some output)
(return output)
@@ -3397,7 +3469,7 @@
(#NamedT [module name] _)
(do Monad<Lux>
[=module (find-module module)
- #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _} =module]]
+ #let [{#module-hash _ #module-aliases _ #defs bindings #imports _ #tags tags #types types #module-anns _ #module-state _} =module]]
(case (get name types)
(#Some [tags exported? (#NamedT _ _type)])
(case (resolve-struct-type _type)
@@ -3419,7 +3491,7 @@
(let [{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars} state]
+ #scope-type-vars scope-type-vars #catching _} state]
(case expected
(#Some type)
(#Right state type)
@@ -3850,22 +3922,22 @@
(def: (replace pattern value template)
(-> Text Text Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+ (_lux_proc ["text" "replace-all"] [template pattern value]))
(def: (clean-module module)
(-> Text (Lux Text))
(do Monad<Lux>
- [module-name current-module-name]
+ [current-module current-module-name]
(case (split-module module)
(^ (list& "." parts))
- (return (|> (list& module-name parts) (interpose "/") reverse (fold Text/append "")))
+ (return (|> (list& current-module parts) (interpose "/") reverse (fold Text/append "")))
parts
(let [[ups parts'] (split-with (Text/= "..") parts)
num-ups (length ups)]
(if (i.= num-ups 0)
(return module)
- (case (nth num-ups (split-module-contexts module-name))
+ (case (nth num-ups (split-module-contexts current-module))
#None
(fail (Text/append "Can't clean module: " module))
@@ -3884,7 +3956,8 @@
[_ (#SymbolS "" m-name)]
(do Monad<Lux>
[m-name (clean-module m-name)]
- (wrap (list [m-name #None {#refer-defs #All #refer-open (list)}])))
+ (wrap (list [m-name #None {#refer-defs #All
+ #refer-open (list)}])))
(^ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))])
(do Monad<Lux>
@@ -3942,7 +4015,7 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars}
+ #scope-type-vars scope-type-vars #catching _}
modules)]
(case (get module modules)
(#Some =module)
@@ -3956,7 +4029,7 @@
_
(list))))
- (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _} =module]
+ (let [{#module-hash _ #module-aliases _ #defs defs #imports _ #tags tags #types types #module-anns _ #module-state _} =module]
defs))]
(#Right state (List/join to-alias)))
@@ -3997,7 +4070,7 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars}
+ #scope-type-vars scope-type-vars #catching _}
(find (: (-> Scope (Maybe Type))
(lambda [env]
(case env
@@ -4017,12 +4090,12 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars} state]
+ #scope-type-vars scope-type-vars #catching _} state]
(case (get v-prefix modules)
#None
#None
- (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _})
+ (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _})
(case (get v-name defs)
#None
#None
@@ -4036,12 +4109,12 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars} state]
+ #scope-type-vars scope-type-vars #catching _} state]
(case (get v-prefix modules)
#None
(#Left (Text/append "Unknown definition: " (Ident/encode name)))
- (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _})
+ (#Some {#defs defs #module-hash _ #module-aliases _ #imports _ #tags tags #types types #module-anns _ #module-state _})
(case (get v-name defs)
#None
(#Left (Text/append "Unknown definition: " (Ident/encode name)))
@@ -4134,13 +4207,13 @@
($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")
(#BoundT id)
- (Nat->Text id)
+ (Nat/encode id)
(#VarT id)
- ($_ Text/append "⌈v:" (->Text id) "⌋")
+ ($_ Text/append "⌈v:" (Nat/encode id) "⌋")
(#ExT id)
- ($_ Text/append "⟨e:" (->Text id) "⟩")
+ ($_ Text/append "⟨e:" (Nat/encode id) "⟩")
(#UnivQ env body)
($_ Text/append "(All " (Type/show body) ")")
@@ -4330,12 +4403,12 @@
(macro: #export (|>. tokens)
{#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it.
- (|> (map ->Text) (interpose \" \") (fold Text/append \"\"))
+ (|> (map Int/encode) (interpose \" \") (fold Text/append \"\"))
## =>
(lambda [<something>]
(fold Text/append \"\"
(interpose \" \"
- (map ->Text <something>))))"}
+ (map Int/encode <something>))))"}
(do Monad<Lux>
[g!arg (gensym "arg")]
(return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens))))))))
@@ -4344,29 +4417,9 @@
(-> Text Text (Lux Bool))
(do Monad<Lux>
[module (find-module module-name)
- #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _} module]]
+ #let [{#module-hash _ #module-aliases _ #defs _ #imports imports #tags _ #types _ #module-anns _ #module-state _} module]]
(wrap (is-member? imports import-name))))
-(macro: #export (default tokens state)
- {#;doc "## Allows you to provide a default value that will be used
- ## if a (Maybe x) value turns out to be #;None.
- (default 20 (#;Some 10)) => 10
-
- (default 20 #;None) => 20"}
- (case tokens
- (^ (list else maybe))
- (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])])
- code (` (case (~ maybe)
- (#;Some (~ g!temp))
- (~ g!temp)
-
- #;None
- (~ else)))]
- (#;Right [state (list code)]))
-
- _
- (#;Left "Wrong syntax for ?")))
-
(def: (read-refer module-name options)
(-> Text (List AST) (Lux Refer))
(do Monad<Lux>
@@ -4759,17 +4812,17 @@
_
(fail "Wrong syntax for ^template")))
-(do-template [<name> <from> <to> <converter>]
+(do-template [<name> <from> <to> <proc>]
[(def: #export (<name> n)
(-> <from> <to>)
- (_lux_proc ["jvm" <converter>] [n]))]
+ (_lux_proc <proc> [n]))]
- [real-to-int Real Int "d2l"]
- [int-to-real Int Real "l2d"]
+ [real-to-int Real Int ["real" "to-int"]]
+ [int-to-real Int Real ["int" "to-real"]]
)
(def: (find-baseline-column ast)
- (-> AST Int)
+ (-> AST Nat)
(case ast
(^template [<tag>]
[[_ _ column] (<tag> _)]
@@ -4786,12 +4839,12 @@
(^template [<tag>]
[[_ _ column] (<tag> parts)]
- (fold i.min column (map find-baseline-column parts)))
+ (fold n.min column (map find-baseline-column parts)))
([#FormS]
[#TupleS])
[[_ _ column] (#RecordS pairs)]
- (fold i.min column
+ (fold n.min column
(List/append (map (. find-baseline-column first) pairs)
(map (. find-baseline-column second) pairs)))
))
@@ -4809,23 +4862,11 @@
_
(#Doc-Example ast)))
-(def: (Char/encode x)
- (-> Char Text)
- (let [as-text (case x
- #"\t" "\\t"
- #"\b" "\\b"
- #"\n" "\\n"
- #"\r" "\\r"
- #"\f" "\\f"
- #"\"" "\\\""
- #"\\" "\\\\"
- _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
- ($_ Text/append "#\"" as-text "\"")))
-
(def: (Text/encode original)
(-> Text Text)
(let [escaped (|> original
(replace "\t" "\\t")
+ (replace "\v" "\\v")
(replace "\b" "\\b")
(replace "\n" "\\n")
(replace "\r" "\\r")
@@ -4841,16 +4882,27 @@
(-> <type> <type>)
(<op> <one> value))]
- [i.inc i.+ 1 Int "Increment function."]
- [i.dec i.- 1 Int "Decrement function."]
- [n.inc n.+ +1 Nat "Increment function."]
- [n.dec n.- +1 Nat "Decrement function."]
+ [i.inc i.+ 1 Int "[Int] Increment function."]
+ [i.dec i.- 1 Int "[Int] Decrement function."]
+ [n.inc n.+ +1 Nat "[Nat] Increment function."]
+ [n.dec n.- +1 Nat "[Nat] Decrement function."]
)
-(def: tag->Text
+(def: Tag/encode
(-> Ident Text)
(. (Text/append "#") Ident/encode))
+(do-template [<name> <op> <from> <to>]
+ [(def: #export (<name> input)
+ (-> <from> <to>)
+ (_lux_proc <op> [input]))]
+
+ [int-to-nat ["int" "to-nat"] Int Nat]
+ [nat-to-int ["nat" "to-int"] Nat Int]
+ [real-to-deg ["real" "to-deg"] Real Deg]
+ [deg-to-real ["deg" "to-real"] Deg Real]
+ )
+
(def: (repeat n x)
(All [a] (-> Int a (List a)))
(if (i.> 0 n)
@@ -4858,36 +4910,35 @@
#;Nil))
(def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column])
- (-> Int Cursor Cursor Text)
- (if (i.= old-line new-line)
- (Text/join (repeat (i.- old-column new-column) " "))
- (let [extra-lines (Text/join (repeat (i.- old-line new-line) "\n"))
- space-padding (Text/join (repeat (i.- baseline new-column) " "))]
+ (-> Nat Cursor Cursor Text)
+ (if (n.= old-line new-line)
+ (Text/join (repeat (nat-to-int (n.- old-column new-column)) " "))
+ (let [extra-lines (Text/join (repeat (nat-to-int (n.- old-line new-line)) "\n"))
+ space-padding (Text/join (repeat (nat-to-int (n.- baseline new-column)) " "))]
(Text/append extra-lines space-padding))))
(def: (Text/size x)
- (-> Text Int)
- (_lux_proc ["jvm" "i2l"]
- [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))
+ (-> Text Nat)
+ (_lux_proc ["text" "size"] [x]))
(def: (Text/trim x)
(-> Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:trim:"] [x]))
+ (_lux_proc ["text" "trim"] [x]))
(def: (update-cursor [file line column] ast-text)
(-> Cursor Text Cursor)
- [file line (i.+ column (Text/size ast-text))])
+ [file line (n.+ column (Text/size ast-text))])
(def: (delim-update-cursor [file line column])
(-> Cursor Cursor)
- [file line (i.inc column)])
+ [file line (n.inc column)])
(def: rejoin-all-pairs
(-> (List [AST AST]) (List AST))
(. List/join (map rejoin-pair)))
(def: (doc-example->Text prev-cursor baseline example)
- (-> Cursor Int AST [Cursor Text])
+ (-> Cursor Nat AST [Cursor Text])
(case example
(^template [<tag> <show>]
[new-cursor (<tag> value)]
@@ -4895,15 +4946,15 @@
[(update-cursor new-cursor as-text)
(Text/append (cursor-padding baseline prev-cursor new-cursor)
as-text)]))
- ([#BoolS ->Text]
- [#NatS Nat->Text]
- [#IntS ->Text]
- [#DegS Deg->Text]
- [#RealS ->Text]
+ ([#BoolS Bool/encode]
+ [#NatS Nat/encode]
+ [#IntS Int/encode]
+ [#DegS Deg/encode]
+ [#RealS Real/encode]
[#CharS Char/encode]
[#TextS Text/encode]
[#SymbolS Ident/encode]
- [#TagS tag->Text])
+ [#TagS Tag/encode])
(^template [<tag> <open> <close> <prep>]
[group-cursor (<tag> parts)]
@@ -4923,7 +4974,7 @@
))
(def: (with-baseline baseline [file line column])
- (-> Int Cursor Cursor)
+ (-> Nat Cursor Cursor)
[file line baseline])
(def: (doc-fragment->Text fragment)
@@ -5142,7 +5193,7 @@
(compare <text> (:: AST/encode show <expr>))
(compare true (:: Eq<AST> = <expr> <expr>))]
- [(bool true) "true" [["" -1 -1] (#;BoolS true)]]
+ [(bool true) "true" [_ (#;BoolS true)]]
[(bool false) "false" [_ (#;BoolS false)]]
[(int 123) "123" [_ (#;IntS 123)]]
[(real 123.0) "123.0" [_ (#;RealS 123.0)]]
@@ -5390,7 +5441,7 @@
{#info info #source source #modules modules
#scopes scopes #type-vars types #host host
#seed seed #expected expected #cursor cursor
- #scope-type-vars scope-type-vars}
+ #scope-type-vars scope-type-vars #catching _}
(#Right state scope-type-vars)
))
@@ -5423,7 +5474,7 @@
(wrap (list (` (#ExT (~ (nat$ var-id))))))
#;None
- (fail (Text/append "Indexed-type doesn't exist: " (->Text idx)))))
+ (fail (Text/append "Indexed-type doesn't exist: " (Nat/encode idx)))))
_
(fail "Wrong syntax for $")))
@@ -5437,7 +5488,7 @@
"This one should fail:"
(is 5 (i.+ 2 3)))}
(All [a] (-> a a Bool))
- (_lux_proc ["lux" "=="] [left right]))
+ (_lux_proc ["lux" "is"] [left right]))
(macro: #export (^@ tokens)
{#;doc (doc "Allows you to simultaneously bind and de-structure a value."
@@ -5483,12 +5534,6 @@
_
(fail "Wrong syntax for :!!")))
-(def: #export (error! message)
- {#;doc (doc "Causes an error, with the given error message."
- (error! "OH NO!"))}
- (-> Text Bottom)
- (_lux_proc ["jvm" "throw"] [(_lux_proc ["jvm" "new:java.lang.Error:java.lang.String"] [message])]))
-
(def: #hidden hack_Text/append
(-> Text Text Text)
Text/append)
@@ -5499,7 +5544,7 @@
(let [{#;info info #;source source #;modules modules #;scopes scopes
#;type-vars types #;host host #;seed seed
#;expected expected #;cursor cursor
- #;scope-type-vars scope-type-vars} state]
+ #;scope-type-vars scope-type-vars #catching _} state]
(#;Right [state cursor]))))
(macro: #export (with-cursor tokens)
@@ -5513,7 +5558,7 @@
(do Monad<Lux>
[cursor get-cursor]
(let [[module line column] cursor
- cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")]
+ cursor-prefix ($_ hack_Text/append "[" module "," (Nat/encode line) "," (Nat/encode column) "] ")]
(wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message)))))))
_
@@ -5567,18 +5612,6 @@
_
(fail "Wrong syntax for @post")))
-(do-template [<name> <op> <from> <to>]
- [(def: #export (<name> input)
- (-> <from> <to>)
- (_lux_proc <op> [input]))]
-
- [int-to-nat ["int" "to-nat"] Int Nat]
- [nat-to-int ["nat" "to-int"] Nat Int]
-
- [real-to-deg ["real" "to-deg"] Real Deg]
- [deg-to-real ["deg" "to-real"] Deg Real]
- )
-
(macro: #export (type-of tokens)
{#;doc (doc "Generates the type corresponding to a given definition or variable."
(let [my-num (: Int 123)]
@@ -5716,3 +5749,7 @@
(type: #export (<.> f g)
(All [a] (f (g a))))
+
+(def: #export (assume mx)
+ (All [a] (-> (Maybe a) a))
+ (default (undefined) mx))
diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux
index 09dd642ed..f2ec8b46c 100644
--- a/stdlib/source/lux/concurrency/atom.lux
+++ b/stdlib/source/lux/concurrency/atom.lux
@@ -1,31 +1,25 @@
(;module:
lux
- (lux [io #- run]
- host))
-
-(jvm-import (java.util.concurrent.atomic.AtomicReference V)
- (new [V])
- (compareAndSet [V V] boolean)
- (get [] V))
+ (lux [io #- run]))
(type: #export (Atom a)
{#;doc "Atomic references that are safe to mutate concurrently."}
- (AtomicReference a))
+ (#;HostT "#Atom" (#;Cons a #;Nil)))
(def: #export (atom value)
(All [a] (-> a (Atom a)))
- (AtomicReference.new [value]))
+ (_lux_proc ["atom" "new"] [value]))
(def: #export (get atom)
(All [a] (-> (Atom a) (IO a)))
- (io (AtomicReference.get [] atom)))
+ (io (_lux_proc ["atom" "get"] [atom])))
(def: #export (compare-and-swap current new atom)
{#;doc "Only mutates an atom if you can present it's current value.
That guarantees that atom wasn't updated since you last read from it."}
(All [a] (-> a a (Atom a) (IO Bool)))
- (io (AtomicReference.compareAndSet [current new] atom)))
+ (io (_lux_proc ["atom" "compare-and-swap"] [atom current new])))
(def: #export (update f atom)
{#;doc "Updates an atom by applying a function to its current value.
@@ -34,8 +28,8 @@
The retries will be done with the new values of the atom, as they show up."}
(All [a] (-> (-> a a) (Atom a) (IO Unit)))
- (io (let [old (AtomicReference.get [] atom)]
- (if (AtomicReference.compareAndSet [old (f old)] atom)
+ (io (let [old (_lux_proc ["atom" "get"] [atom])]
+ (if (_lux_proc ["atom" "compare-and-swap"] [atom old (f old)])
[]
(io;run (update f atom))))))
diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux
index 3c10e785d..ef7efd923 100644
--- a/stdlib/source/lux/concurrency/promise.lux
+++ b/stdlib/source/lux/concurrency/promise.lux
@@ -12,47 +12,11 @@
[compiler]
(macro ["s" syntax #+ syntax: Syntax])
(concurrency [atom #+ Atom atom])
- host
))
-(jvm-import java.lang.Runtime
- (#static getRuntime [] Runtime)
- (availableProcessors [] int))
-
-(jvm-import java.lang.Runnable)
-
-(jvm-import java.lang.Thread
- (new [Runnable])
- (start [] void))
-
-(jvm-import java.util.concurrent.Executor
- (execute [Runnable] void))
-
-(jvm-import java.util.concurrent.TimeUnit
- (#enum MILLISECONDS))
-
-(jvm-import (java.util.concurrent.ScheduledFuture a))
-
-(jvm-import java.util.concurrent.ScheduledThreadPoolExecutor
- (new [int])
- (schedule [Runnable long TimeUnit] (ScheduledFuture Object)))
-
(def: #export concurrency-level
Nat
- (|> (Runtime.getRuntime [])
- (Runtime.availableProcessors [])
- int-to-nat))
-
-(def: executor
- ScheduledThreadPoolExecutor
- (ScheduledThreadPoolExecutor.new [(nat-to-int concurrency-level)]))
-
-(syntax: (runnable expr)
- (wrap (list (`' (object [java.lang.Runnable]
- []
- (java.lang.Runnable (run) void
- (exec (~ expr)
- [])))))))
+ (_lux_proc ["process" "concurrency-level"] []))
(type: (Promise-State a)
{#value (Maybe a)
@@ -218,18 +182,15 @@
{#;doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."}
(All [a] (-> (IO a) (Promise a)))
(let [!out (promise ($ +0))]
- (exec (Thread.start [] (Thread.new [(runnable (io;run (resolve (io;run computation)
- !out)))]))
+ (exec (_lux_proc ["process" "future"] [(io (io;run (resolve (io;run computation)
+ !out)))])
!out)))
(def: #export (wait time)
{#;doc "Returns a Promise that will be resolved after the specified amount of milliseconds."}
(-> Nat (Promise Unit))
(let [!out (promise Unit)]
- (exec (ScheduledThreadPoolExecutor.schedule [(runnable (io;run (resolve [] !out)))
- (nat-to-int time)
- TimeUnit.MILLISECONDS]
- executor)
+ (exec (_lux_proc ["process" "schedule"] [time (resolve [] !out)])
!out)))
(def: #export (time-out time promise)
diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux
index 36eb6854e..c1c3153dd 100644
--- a/stdlib/source/lux/concurrency/stm.lux
+++ b/stdlib/source/lux/concurrency/stm.lux
@@ -12,7 +12,6 @@
maybe
[number "Nat/" Codec<Text,Nat>]
text/format)
- host
[compiler]
(macro [ast]
["s" syntax #+ syntax: Syntax])
diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux
index f78ffea17..5ed443040 100644
--- a/stdlib/source/lux/control/comonad.lux
+++ b/stdlib/source/lux/control/comonad.lux
@@ -18,6 +18,8 @@
split))
## [Syntax]
+(def: _cursor Cursor ["" +0 +0])
+
(macro: #export (be tokens state)
{#;doc (doc "A co-monadic parallel to the \"do\" macro."
(let [square (lambda [n] (i.* n n))]
@@ -26,9 +28,8 @@
(square (head inputs)))))}
(case tokens
(#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
- (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])])
- g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
- g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])])
+ (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])])
+ g!split (: AST [_cursor (#;SymbolS ["" " split "])])
body' (fold (: (-> [AST AST] AST AST)
(lambda [binding body']
(let [[var value] binding]
@@ -42,8 +43,8 @@
body
(reverse (as-pairs bindings)))]
(#;Right [state (#;Cons (` (;_lux_case (~ comonad)
- (~ g!@)
- (;_lux_case (~ g!@)
+ (~' @)
+ (;_lux_case (~' @)
{#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)}
(~ body'))))
#;Nil)]))
diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux
index 5c540791a..a6d0d5988 100644
--- a/stdlib/source/lux/control/monad.lux
+++ b/stdlib/source/lux/control/monad.lux
@@ -49,6 +49,8 @@
join))
## [Syntax]
+(def: _cursor Cursor ["" +0 +0])
+
(macro: #export (do tokens state)
{#;doc (doc "Macro for easy concatenation of monadic operations."
(do Monad<Maybe>
@@ -57,10 +59,9 @@
(wrap (f3 z))))}
(case tokens
(#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
- (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])])
- g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
- g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])])
- g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])])
+ (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])])
+ g!join (: AST [_cursor (#;SymbolS ["" " join "])])
+ g!apply (: AST [_cursor (#;SymbolS ["" " apply "])])
body' (fold (: (-> [AST AST] AST AST)
(lambda [binding body']
(let [[var value] binding]
@@ -74,8 +75,8 @@
body
(reverse (as-pairs bindings)))]
(#;Right [state (#;Cons (` (;_lux_case (~ monad)
- (~ g!@)
- (;_lux_case (~ g!@)
+ (~' @)
+ (;_lux_case (~' @)
{#applicative {#A;functor {#F;map (~ g!map)}
#A;wrap (~' wrap)
#A;apply (~ g!apply)}
diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux
index 28877ae34..0db90898e 100644
--- a/stdlib/source/lux/data/char.lux
+++ b/stdlib/source/lux/data/char.lux
@@ -9,48 +9,43 @@
## [Structures]
(struct: #export _ (Eq Char)
(def: (= x y)
- (_lux_proc ["jvm" "ceq"] [x y])))
+ (_lux_proc ["char" "="] [x y])))
(struct: #export _ (Hash Char)
(def: eq Eq<Char>)
- (def: hash
- (|>. []
- (_lux_proc ["jvm" "c2i"])
- []
- (_lux_proc ["jvm" "i2l"])
- int-to-nat)))
+ (def: (hash input)
+ (_lux_proc ["char" "to-nat"] [input])))
(struct: #export _ (ord;Ord Char)
(def: eq Eq<Char>)
- (do-template [<name> <op>]
- [(def: (<name> test subject)
- (_lux_proc ["jvm" <op>] [subject test]))]
+ (def: (< test subject)
+ (_lux_proc ["char" "<"] [subject test]))
- [< "clt"]
- [> "cgt"]
- )
+ (def: (<= test subject)
+ (or (_lux_proc ["char" "="] [subject test])
+ (_lux_proc ["char" "<"] [subject test])))
- (do-template [<name> <op>]
- [(def: (<name> test subject)
- (or (_lux_proc ["jvm" "ceq"] [subject test])
- (_lux_proc ["jvm" <op>] [subject test])))]
+ (def: (> test subject)
+ (_lux_proc ["char" "<"] [test subject]))
- [<= "clt"]
- [>= "cgt"]
- ))
+ (def: (>= test subject)
+ (or (_lux_proc ["char" "="] [test subject])
+ (_lux_proc ["char" "<"] [test subject])))
+ )
(struct: #export _ (Codec Text Char)
(def: (encode x)
(let [as-text (case x
#"\t" "\\t"
+ #"\v" "\\v"
#"\b" "\\b"
#"\n" "\\n"
#"\r" "\\r"
#"\f" "\\f"
#"\"" "\\\""
#"\\" "\\\\"
- _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
+ _ (_lux_proc ["char" "to-text"] [x]))]
($_ Text/append "#\"" as-text "\"")))
(def: (decode y)
@@ -70,13 +65,13 @@
[(#;Some #"\\") (#;Some char)]
(case char
#"t" (#;Right #"\t")
+ #"v" (#;Right #"\v")
#"b" (#;Right #"\b")
#"n" (#;Right #"\n")
#"r" (#;Right #"\r")
#"f" (#;Right #"\f")
#"\"" (#;Right #"\"")
#"\\" (#;Right #"\\")
- #"t" (#;Right #"\t")
_ (#;Left (Text/append "Wrong syntax for Char: " y)))
_
@@ -84,14 +79,19 @@
(#;Left (Text/append "Wrong syntax for Char: " y))))))
## [Values]
-(def: #export (space? x)
+(def: #export (space? char)
{#;doc "Checks whether the character is white-space."}
(-> Char Bool)
- (_lux_proc ["jvm" "invokestatic:java.lang.Character:isWhitespace:char"] [x]))
+ (case char
+ (^or #"\t" #"\v" #" " #"\n" #"\r" #"\f")
+ true
+
+ _
+ false))
(def: #export (as-text x)
(-> Char Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))
+ (_lux_proc ["char" "to-text"] [x]))
(def: #export (char x)
(-> Nat Char)
diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux
index 4d9d9c270..5f2ef3984 100644
--- a/stdlib/source/lux/data/coll/list.lux
+++ b/stdlib/source/lux/data/coll/list.lux
@@ -335,7 +335,7 @@
## [Syntax]
(def: (symbol$ name)
(-> Text AST)
- [["" -1 -1] (#;SymbolS "" name)])
+ [["" +0 +0] (#;SymbolS "" name)])
(macro: #export (zip tokens state)
{#;doc (doc "Create list zippers with the specified number of input lists."
diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux
index 998b42ea8..1a29fc5b6 100644
--- a/stdlib/source/lux/data/number.lux
+++ b/stdlib/source/lux/data/number.lux
@@ -17,7 +17,7 @@
[ Nat n.=]
[ Int i.=]
- [Deg d.=]
+ [ Deg d.=]
[Real r.=]
)
@@ -29,9 +29,9 @@
(def: > <gt>)
(def: >= <gte>))]
- [ Nat Eq<Nat> n.< n.<= n.> n.>=]
- [ Int Eq<Int> i.< i.<= i.> i.>=]
- [Deg Eq<Deg> d.< d.<= d.> d.>=]
+ [ Nat Eq<Nat> n.< n.<= n.> n.>=]
+ [ Int Eq<Int> i.< i.<= i.> i.>=]
+ [Deg Eq<Deg> d.< d.<= d.> d.>=]
[Real Eq<Real> r.< r.<= r.> r.>=]
)
@@ -100,38 +100,34 @@
(def: top <top>)
(def: bottom <bottom>))]
- [ Nat Ord<Nat> (_lux_proc ["nat" "max-value"] []) (_lux_proc ["nat" "min-value"] [])]
- [ Int Ord<Int> (_lux_proc ["jvm" "getstatic:java.lang.Long:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Long:MIN_VALUE"] [])]
- [Real Ord<Real> (_lux_proc ["jvm" "getstatic:java.lang.Double:MAX_VALUE"] []) (_lux_proc ["jvm" "getstatic:java.lang.Double:MIN_VALUE"] [])]
- [Deg Ord<Deg> (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "min-value"] [])])
+ [ Nat Ord<Nat> (_lux_proc [ "nat" "max-value"] []) (_lux_proc [ "nat" "min-value"] [])]
+ [ Int Ord<Int> (_lux_proc [ "int" "max-value"] []) (_lux_proc [ "int" "min-value"] [])]
+ [Real Ord<Real> (_lux_proc ["real" "max-value"] []) (_lux_proc ["real" "min-value"] [])]
+ [ Deg Ord<Deg> (_lux_proc [ "deg" "max-value"] []) (_lux_proc [ "deg" "min-value"] [])])
(do-template [<name> <type> <unit> <append>]
[(struct: #export <name> (Monoid <type>)
(def: unit <unit>)
(def: (append x y) (<append> x y)))]
- [ Add@Monoid<Nat> Nat +0 n.+]
- [ Mul@Monoid<Nat> Nat +1 n.*]
+ [ Add@Monoid<Nat> Nat +0 n.+]
+ [ Mul@Monoid<Nat> Nat +1 n.*]
[ Max@Monoid<Nat> Nat (:: Interval<Nat> bottom) n.max]
[ Min@Monoid<Nat> Nat (:: Interval<Nat> top) n.min]
- [ Add@Monoid<Int> Int 0 i.+]
- [ Mul@Monoid<Int> Int 1 i.*]
+ [ Add@Monoid<Int> Int 0 i.+]
+ [ Mul@Monoid<Int> Int 1 i.*]
[ Max@Monoid<Int> Int (:: Interval<Int> bottom) i.max]
[ Min@Monoid<Int> Int (:: Interval<Int> top) i.min]
- [Add@Monoid<Real> Real 0.0 r.+]
- [Mul@Monoid<Real> Real 1.0 r.*]
+ [Add@Monoid<Real> Real 0.0 r.+]
+ [Mul@Monoid<Real> Real 1.0 r.*]
[Max@Monoid<Real> Real (:: Interval<Real> bottom) r.max]
[Min@Monoid<Real> Real (:: Interval<Real> top) r.min]
- [Add@Monoid<Deg> Deg (:: Interval<Deg> bottom) d.+]
- [Mul@Monoid<Deg> Deg (:: Interval<Deg> top) d.*]
- [Max@Monoid<Deg> Deg (:: Interval<Deg> bottom) d.max]
- [Min@Monoid<Deg> Deg (:: Interval<Deg> top) d.min]
+ [ Add@Monoid<Deg> Deg (:: Interval<Deg> bottom) d.+]
+ [ Mul@Monoid<Deg> Deg (:: Interval<Deg> top) d.*]
+ [ Max@Monoid<Deg> Deg (:: Interval<Deg> bottom) d.max]
+ [ Min@Monoid<Deg> Deg (:: Interval<Deg> top) d.min]
)
-(def: (text.replace pattern value template)
- (-> Text Text Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
-
(do-template [<type> <encoder> <decoder> <error>]
[(struct: #export _ (Codec Text <type>)
(def: (encode x)
@@ -145,26 +141,10 @@
#;None
(#;Left <error>))))]
- [Nat ["nat" "encode"] ["nat" "decode"] "Couldn't decode Nat"]
- [Deg ["deg" "encode"] ["deg" "decode"] "Couldn't decode Deg"]
- )
-
-(def: clean-number
- (-> Text Text)
- (text.replace "_" ""))
-
-(do-template [<type> <encode> <decode> <error>]
- [(struct: #export _ (Codec Text <type>)
- (def: (encode x)
- (_lux_proc ["jvm" <encode>] [x]))
-
- (def: (decode input)
- (_lux_proc ["jvm" "try"]
- [(#;Right (_lux_proc ["jvm" <decode>] [(clean-number input)]))
- (lambda [e] (#;Left <error>))])))]
-
- [ Int "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Long:parseLong:java.lang.String" "Couldn't parse Int"]
- [Real "invokevirtual:java.lang.Object:toString:" "invokestatic:java.lang.Double:parseDouble:java.lang.String" "Couldn't parse Real"]
+ [ Nat [ "nat" "encode"] [ "nat" "decode"] "Couldn't decode Nat"]
+ [ Int [ "int" "encode"] [ "int" "decode"] "Couldn't decode Int"]
+ [ Deg [ "deg" "encode"] [ "deg" "decode"] "Couldn't decode Deg"]
+ [Real ["real" "encode"] ["real" "decode"] "Couldn't decode Real"]
)
(struct: #export _ (Hash Nat)
@@ -178,24 +158,59 @@
(struct: #export _ (Hash Real)
(def: eq Eq<Real>)
- (def: hash
- (|>. (:: Codec<Text,Real> encode)
- []
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"])
- []
- (_lux_proc ["jvm" "i2l"])
- int-to-nat)))
+ (def: (hash value)
+ (_lux_proc ["real" "hash"] [value])))
+
+(do-template [<name> <const> <doc>]
+ [(def: #export <name>
+ {#;doc <doc>}
+ Real
+ (_lux_proc ["real" <const>] []))]
+
+ [not-a-number "not-a-number" "Not-a-number."]
+ [positive-infinity "positive-infinity" "Positive infinity."]
+ [negative-infinity "negative-infinity" "Negative infinity."]
+ )
+
+(def: #export (not-a-number? number)
+ {#;doc "Tests whether a real is actually not-a-number."}
+ (-> Real Bool)
+ (not (r.= number number)))
## [Values & Syntax]
-(do-template [<struct> <to-proc> <radix> <macro> <error> <doc>]
+(do-template [<struct> <base> <macro> <error> <char-set> <doc>]
[(struct: #export <struct> (Codec Text Nat)
(def: (encode value)
- (_lux_proc ["jvm" <to-proc>] [(nat-to-int value)]))
+ (loop [input value
+ output ""]
+ (let [digit (assume (_lux_proc ["text" "char"] [<char-set> (n.% <base> input)]))
+ output' (_lux_proc ["text" "append"] [(_lux_proc ["char" "to-text"] [digit])
+ output])
+ input' (n./ <base> input)]
+ (if (n.= +0 input')
+ output'
+ (recur input' output')))))
(def: (decode repr)
- (_lux_proc ["jvm" "try"]
- [(#;Right (int-to-nat (_lux_proc ["jvm" "invokestatic:java.lang.Long:parseUnsignedLong:java.lang.String,int"] [repr (_lux_proc ["jvm" "l2i"] [<radix>])])))
- (lambda [ex] (#;Left <error>))])))
+ (let [input-size (_lux_proc ["text" "size"] [repr])]
+ (if (n.= +0 input-size)
+ (#;Left "Empty input.")
+ (let [input (_lux_proc ["text" "upper-case"] [repr])]
+ (loop [idx +0
+ output +0]
+ (if (n.< input-size idx)
+ (let [digit (assume (_lux_proc ["text" "char"] [input idx]))]
+ (case (_lux_proc ["text" "index"]
+ [<char-set>
+ (_lux_proc ["char" "to-text"] [digit])
+ +0])
+ #;None
+ (#;Left <error>)
+
+ (#;Some index)
+ (recur (n.inc idx)
+ (|> output (n.* <base>) (n.+ index)))))
+ (#;Right output))))))))
(macro: #export (<macro> tokens state)
{#;doc <doc>}
@@ -211,29 +226,16 @@
_
(#;Left <error>)))]
- [Binary@Codec<Text,Nat> "invokestatic:java.lang.Long:toBinaryString:long" 2 bin "Invalid binary syntax."
+ [Binary@Codec<Text,Nat> +2 bin "Invalid binary syntax."
+ "01"
(doc "Given syntax for a binary number, generates a Nat."
(bin "11001001"))]
- [Octal@Codec<Text,Nat> "invokestatic:java.lang.Long:toOctalString:long" 8 oct "Invalid octal syntax."
+ [Octal@Codec<Text,Nat> +8 oct "Invalid octal syntax."
+ "01234567"
(doc "Given syntax for an octal number, generates a Nat."
(oct "615243"))]
- [Hex@Codec<Text,Nat> "invokestatic:java.lang.Long:toHexString:long" 16 hex "Invalid hexadecimal syntax."
+ [Hex@Codec<Text,Nat> +16 hex "Invalid hexadecimal syntax."
+ "0123456789ABCDEF"
(doc "Given syntax for a hexadecimal number, generates a Nat."
(hex "deadBEEF"))]
)
-
-(do-template [<name> <field> <doc>]
- [(def: #export <name>
- {#;doc <doc>}
- Real
- (_lux_proc ["jvm" <field>] []))]
-
- [nan "getstatic:java.lang.Double:NaN" "Not-a-number."]
- [+inf "getstatic:java.lang.Double:POSITIVE_INFINITY" "Positive infinity."]
- [-inf "getstatic:java.lang.Double:NEGATIVE_INFINITY" "Negative infinity."]
- )
-
-(def: #export (nan? number)
- {#;doc "Tests whether a real is actually not-a-number."}
- (-> Real Bool)
- (not (r.= number number)))
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
index bec6d7d2b..4869d9e82 100644
--- a/stdlib/source/lux/data/text.lux
+++ b/stdlib/source/lux/data/text.lux
@@ -12,67 +12,53 @@
## [Functions]
(def: #export (size x)
(-> Text Nat)
- (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])))
+ [(_lux_proc ["text" "size"] [x])])
-(def: #export (nth idx x)
+(def: #export (nth idx input)
(-> Nat Text (Maybe Char))
- (if (n.< (size x) idx)
- (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])]))
- #;None))
+ (_lux_proc ["text" "char"] [input idx]))
(def: #export (contains? sub text)
(-> Text Text Bool)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:contains:java.lang.CharSequence"] [text sub]))
+ (_lux_proc ["text" "contains?"] [text sub]))
(do-template [<name> <proc>]
- [(def: #export (<name> x)
+ [(def: #export (<name> input)
(-> Text Text)
- (_lux_proc ["jvm" <proc>] [x]))]
- [lower-case "invokevirtual:java.lang.String:toLowerCase:"]
- [upper-case "invokevirtual:java.lang.String:toUpperCase:"]
- [trim "invokevirtual:java.lang.String:trim:"]
+ (_lux_proc ["text" <proc>] [input]))]
+ [lower-case "lower-case"]
+ [upper-case "upper-case"]
+ [trim "trim"]
)
-(def: #export (sub from to x)
+(def: #export (clip from to input)
(-> Nat Nat Text (Maybe Text))
- (if (and (n.< to from)
- (n.<= (size x) to))
- (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"]
- [x
- (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])
- (_lux_proc ["jvm" "l2i"] [(nat-to-int to)])]))
- #;None))
+ (_lux_proc ["text" "clip"] [input from to]))
-(def: #export (sub' from x)
+(def: #export (clip' from input)
(-> Nat Text (Maybe Text))
- (sub from (size x) x))
+ (clip from (size input) input))
(def: #export (replace pattern value template)
(-> Text Text Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence"] [template pattern value]))
+ (_lux_proc ["text" "replace-all"] [template pattern value]))
-(do-template [<common> <common-proc> <general> <general-proc>]
- [(def: #export (<common> pattern x)
+(do-template [<general> <common> <proc> <start>]
+ [(def: #export (<common> pattern input)
(-> Text Text (Maybe Nat))
- (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" <common-proc>] [x pattern])])
- -1 #;None
- idx (#;Some (int-to-nat idx))))
+ (_lux_proc ["text" <proc>] [input pattern <start>]))
- (def: #export (<general> pattern from x)
+ (def: #export (<general> pattern from input)
(-> Text Nat Text (Maybe Nat))
- (if (n.< (size x) from)
- (case (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" <general-proc>] [x pattern (_lux_proc ["jvm" "l2i"] [(nat-to-int from)])])])
- -1 #;None
- idx (#;Some (int-to-nat idx)))
- #;None))]
-
- [index-of "invokevirtual:java.lang.String:indexOf:java.lang.String" index-of' "invokevirtual:java.lang.String:indexOf:java.lang.String,int"]
- [last-index-of "invokevirtual:java.lang.String:lastIndexOf:java.lang.String" last-index-of' "invokevirtual:java.lang.String:lastIndexOf:java.lang.String,int"]
+ (_lux_proc ["text" <proc>] [input pattern from]))]
+
+ [index-of index-of' "index" +0]
+ [last-index-of last-index-of' "last-index" (size input)]
)
(def: #export (starts-with? prefix x)
(-> Text Text Bool)
- (case (index-of prefix x)
+ (case (index-of' prefix x)
(#;Some +0)
true
@@ -81,7 +67,7 @@
(def: #export (ends-with? postfix x)
(-> Text Text Bool)
- (case (last-index-of postfix x)
+ (case (last-index-of' postfix x)
(#;Some n)
(n.= (size x)
(n.+ (size postfix) n))
@@ -91,16 +77,17 @@
(def: #export (split at x)
(-> Nat Text (Maybe [Text Text]))
- (if (n.<= (size x) at)
- (let [pre (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int,int"] [x (_lux_proc ["jvm" "l2i"] [0]) (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])
- post (_lux_proc ["jvm" "invokevirtual:java.lang.String:substring:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int at)])])]
- (#;Some [pre post]))
+ (case [(clip +0 at x) (clip' at x)]
+ [(#;Some pre) (#;Some post)]
+ (#;Some [pre post])
+
+ _
#;None))
(def: #export (split-with token sample)
(-> Text Text (Maybe [Text Text]))
(do Monad<Maybe>
- [index (index-of token sample)
+ [index (index-of' token sample)
[pre post'] (split index sample)
[_ post] (split (size token) post')]
(wrap [pre post])))
@@ -120,25 +107,30 @@
## [Structures]
(struct: #export _ (Eq Text)
(def: (= test subject)
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [subject test])))
+ (_lux_proc ["text" "="] [subject test])))
(struct: #export _ (ord;Ord Text)
(def: eq Eq<Text>)
- (do-template [<name> <op>]
- [(def: (<name> test subject)
- (<op> 0
- (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:compareTo:java.lang.String"] [subject test])])))]
+ (def: (< test subject)
+ (_lux_proc ["text" "<"] [subject test]))
+
+ (def: (<= test subject)
+ (or (_lux_proc ["text" "<"] [subject test])
+ (_lux_proc ["text" "="] [subject test])))
- [< i.<]
- [<= i.<=]
- [> i.>]
- [>= i.>=]))
+ (def: (> test subject)
+ (_lux_proc ["text" "<"] [test subject]))
+
+ (def: (>= test subject)
+ (or (_lux_proc ["text" "<"] [test subject])
+ (_lux_proc ["text" "="] [test subject])))
+ )
(struct: #export _ (Monoid Text)
(def: unit "")
- (def: (append x y)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y])))
+ (def: (append left right)
+ (_lux_proc ["text" "append"] [left right])))
(open Monoid<Text>)
@@ -147,6 +139,7 @@
(let [escaped (|> original
(replace "\\" "\\\\")
(replace "\t" "\\t")
+ (replace "\v" "\\v")
(replace "\b" "\\b")
(replace "\n" "\\n")
(replace "\r" "\\r")
@@ -158,11 +151,12 @@
(def: (decode input)
(if (and (starts-with? "\"" input)
(ends-with? "\"" input))
- (case (sub +1 (n.dec (size input)) input)
+ (case (clip +1 (n.dec (size input)) input)
(#;Some input')
(|> input'
(replace "\\\\" "\\")
(replace "\\t" "\t")
+ (replace "\\v" "\v")
(replace "\\b" "\b")
(replace "\\n" "\n")
(replace "\\r" "\r")
@@ -177,12 +171,8 @@
(struct: #export _ (Hash Text)
(def: eq Eq<Text>)
- (def: hash
- (|>. []
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:hashCode:"])
- []
- (_lux_proc ["jvm" "i2l"])
- int-to-nat)))
+ (def: (hash input)
+ (_lux_proc ["text" "hash"] [input])))
(def: #export concat
(-> (List Text) Text)
diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux
new file mode 100644
index 000000000..f935dc8d6
--- /dev/null
+++ b/stdlib/source/lux/host.js.lux
@@ -0,0 +1,83 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data (coll [list #* "L/" Fold<List>]))
+ [compiler #+ with-gensyms]
+ (macro [ast]
+ ["s" syntax #+ syntax: Syntax])
+ ))
+
+(do-template [<name> <type>]
+ [(type: #export <name> (#;HostT <type> #;Nil))]
+
+ [Object "object"]
+ [Function "function"]
+ [Symbol "symbol"]
+ [Undefined "undefined"]
+ )
+
+(do-template [<name> <type>]
+ [(type: #export <name> <type>)]
+
+ [String Text]
+ [Number Real]
+ [Boolean Bool]
+ )
+
+## [Syntax]
+(syntax: #export (set! field-name field-value object)
+ {#;doc (doc "A way to set fields from objects."
+ (set! "foo" 1234 some-object))}
+ (wrap (list (` (;_lux_proc ["js" "set-field"] [(~ object) (~ field-name) (~ field-value)])))))
+
+(syntax: #export (delete! field-name object)
+ {#;doc (doc "A way to delete fields from objects."
+ (delete! "foo" some-object))}
+ (wrap (list (` (;_lux_proc ["js" "delete-field"] [(~ object) (~ field-name)])))))
+
+(syntax: #export (get field-name type object)
+ {#;doc (doc "A way to get fields from objects."
+ (get "ceil" (ref "Math"))
+ (get "ceil" (-> Real Real) (ref "Math")))}
+ (wrap (list (` (:! (~ type)
+ (;_lux_proc ["js" "get-field"] [(~ object) (~ field-name)]))))))
+
+(syntax: #export (object [kvs (s;some (s;seq s;any s;any))])
+ {#;doc (doc "A way to create JavaScript objects."
+ (object)
+ (object "foo" foo "bar" (inc bar)))}
+ (wrap (list (L/fold (lambda [[k v] object]
+ (` (set! (~ k) (~ v) (~ object))))
+ (` (;_lux_proc ["js" "object"] []))
+ kvs))))
+
+(syntax: #export (ref [name s;text] [type (s;opt s;any)])
+ {#;doc (doc "A way to refer to JavaScript variables."
+ (ref "document")
+ (ref "Math.ceil" (-> Real Real)))}
+ (wrap (list (` (:! (~ (default (' ;;Object) type))
+ (;_lux_proc ["js" "ref"] [(~ (ast;text name))]))))))
+
+(do-template [<name> <proc> <doc>]
+ [(syntax: #export (<name>)
+ {#;doc (doc <doc>
+ (<name>))}
+ (wrap (list (` (;_lux_proc ["js" <proc>] [])))))]
+
+ [null "null" "Null object reference."]
+ [undef "undefined" "Undefined."]
+ )
+
+(syntax: #export (call! [shape (s;alt ($_ s;seq s;any (s;tuple (s;some s;any)) (s;opt s;any))
+ ($_ s;seq s;any s;text (s;tuple (s;some s;any)) (s;opt s;any)))])
+ {#;doc (doc "A way to call JavaScript functions and methods."
+ (call! (ref "Math.ceil") [123.45])
+ (call! (ref "Math") "ceil" [123.45]))}
+ (case shape
+ (#;Left [function args ?type])
+ (wrap (list (` (:! (~ (default (' ;;Object) ?type))
+ (;_lux_proc ["js" "call"] [(~ function) (~@ args)])))))
+
+ (#;Right [object field args ?type])
+ (wrap (list (` (:! (~ (default (' ;;Object) ?type))
+ (;_lux_proc ["js" "object-call"] [(~ object) (~ (ast;text field)) (~@ args)])))))))
diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.jvm.lux
index 41d567165..41d567165 100644
--- a/stdlib/source/lux/host.lux
+++ b/stdlib/source/lux/host.jvm.lux
diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux
index 93c01ee85..8a9e6bb9e 100644
--- a/stdlib/source/lux/io.lux
+++ b/stdlib/source/lux/io.lux
@@ -19,7 +19,7 @@
"Some value...")))}
(case tokens
(^ (list value))
- (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])]
+ (let [blank (: AST [["" +0 +0] (#;SymbolS ["" ""])])]
(#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))]))
_
diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux
index 49d68b5c3..6647307dd 100644
--- a/stdlib/source/lux/macro/ast.lux
+++ b/stdlib/source/lux/macro/ast.lux
@@ -27,7 +27,7 @@
## (Meta Cursor (AST' (Meta Cursor))))
## [Utils]
-(def: _cursor Cursor ["" -1 -1])
+(def: _cursor Cursor ["" +0 +0])
## [Functions]
(do-template [<name> <type> <tag>]
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
index e87bb1b1b..c49e82969 100644
--- a/stdlib/source/lux/math.lux
+++ b/stdlib/source/lux/math.lux
@@ -5,7 +5,6 @@
[number "Int/" Number<Int>]
[product]
text/format)
- host
[compiler]
(macro ["s" syntax #+ syntax: Syntax "s/" Functor<Syntax>]
[ast])))
@@ -14,10 +13,10 @@
(do-template [<name> <value>]
[(def: #export <name>
Real
- (_lux_proc ["jvm" <value>] []))]
+ (_lux_proc ["math" <value>] []))]
- [e "getstatic:java.lang.Math:E"]
- [pi "getstatic:java.lang.Math:PI"]
+ [e "e"]
+ [pi "pi"]
)
(def: #export tau
@@ -26,52 +25,40 @@
6.28318530717958647692)
(do-template [<name> <method>]
- [(def: #export (<name> n)
+ [(def: #export (<name> input)
(-> Real Real)
- (_lux_proc ["jvm" <method>] [n]))]
+ (_lux_proc ["math" <method>] [input]))]
- [cos "invokestatic:java.lang.Math:cos:double"]
- [sin "invokestatic:java.lang.Math:sin:double"]
- [tan "invokestatic:java.lang.Math:tan:double"]
+ [cos "cos"]
+ [sin "sin"]
+ [tan "tan"]
- [acos "invokestatic:java.lang.Math:acos:double"]
- [asin "invokestatic:java.lang.Math:asin:double"]
- [atan "invokestatic:java.lang.Math:atan:double"]
+ [acos "acos"]
+ [asin "asin"]
+ [atan "atan"]
- [cosh "invokestatic:java.lang.Math:cosh:double"]
- [sinh "invokestatic:java.lang.Math:sinh:double"]
- [tanh "invokestatic:java.lang.Math:tanh:double"]
+ [cosh "cosh"]
+ [sinh "sinh"]
+ [tanh "tanh"]
- [exp "invokestatic:java.lang.Math:exp:double"]
- [log "invokestatic:java.lang.Math:log:double"]
+ [exp "exp"]
+ [log "log"]
- [root2 "invokestatic:java.lang.Math:sqrt:double"]
- [root3 "invokestatic:java.lang.Math:cbrt:double"]
+ [root2 "root2"]
+ [root3 "root3"]
- [degrees "invokestatic:java.lang.Math:toDegrees:double"]
- [radians "invokestatic:java.lang.Math:toRadians:double"]
+ [ceil "ceil"]
+ [floor "floor"]
+ [round "round"]
)
(do-template [<name> <method>]
- [(def: #export (<name> n)
- (-> Real Real)
- (_lux_proc ["jvm" <method>] [n]))]
-
- [ceil "invokestatic:java.lang.Math:ceil:double"]
- [floor "invokestatic:java.lang.Math:floor:double"]
- )
-
-(def: #export (round n)
- (-> Real Real)
- (int-to-real (_lux_proc ["jvm" "invokestatic:java.lang.Math:round:double"] [n])))
-
-(do-template [<name> <method>]
[(def: #export (<name> param subject)
(-> Real Real Real)
- (_lux_proc ["jvm" <method>] [subject param]))]
+ (_lux_proc ["math" <method>] [subject param]))]
- [atan2 "invokestatic:java.lang.Math:atan2:double,double"]
- [pow "invokestatic:java.lang.Math:pow:double,double"]
+ [atan2 "atan2"]
+ [pow "pow"]
)
(def: #export (log' base input)
diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux
index eae4fbe55..87b1a7d18 100644
--- a/stdlib/source/lux/math/complex.lux
+++ b/stdlib/source/lux/math/complex.lux
@@ -38,9 +38,9 @@
(def: #export zero Complex (complex 0.0 0.0))
-(def: #export (nan? complex)
- (or (number;nan? (get@ #real complex))
- (number;nan? (get@ #imaginary complex))))
+(def: #export (not-a-number? complex)
+ (or (number;not-a-number? (get@ #real complex))
+ (number;not-a-number? (get@ #imaginary complex))))
(def: #export (c.= param input)
(-> Complex Complex Bool)
@@ -317,7 +317,7 @@
(def: (decode input)
(case (do Monad<Maybe>
- [input' (text;sub +1 (n.- +1 (text;size input)) input)]
+ [input' (text;clip +1 (n.- +1 (text;size input)) input)]
(text;split-with "," input'))
#;None
(#;Left (Text/append "Wrong syntax for complex numbers: " input))
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index 82fcabed9..d953b7d65 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -13,16 +13,16 @@
text/format
[error #- fail "Error/" Monad<Error>])
[io #- run]
- ["R" random]
- [host #- try]))
+ ["R" random]))
## [Host]
-(jvm-import java.lang.System
- (#static exit [int] #io void)
- (#static currentTimeMillis [] #io long))
+(def: now
+ (IO Int)
+ (io (_lux_proc ["io" "current-time"] [])))
(do-template [<name> <signal>]
- [(def: #hidden <name> (IO Unit) (System.exit <signal>))]
+ [(def: #hidden <name> (IO Bottom)
+ (io (_lux_proc ["io" "exit"] [<signal>])))]
[exit 0]
[die 1]
@@ -51,9 +51,9 @@
[#let [test-runs (List/map (: (-> [Text (IO Test) Text] (Promise Nat))
(lambda [[module test description]]
(do @
- [#let [pre (io;run (System.currentTimeMillis []))]
+ [#let [pre (io;run now)]
outcome (io;run test)
- #let [post (io;run (System.currentTimeMillis []))
+ #let [post (io;run now)
description+ (:: text;Codec<Text,Text> encode description)]]
(case outcome
(#;Left error)
@@ -107,7 +107,7 @@
(def: #hidden (repeat ?seed times random-test)
(-> (Maybe Nat) Nat (R;Random Test) Test)
- (repeat' (default (int-to-nat (io;run (System.currentTimeMillis [])))
+ (repeat' (default (int-to-nat (io;run now))
?seed)
(case ?seed
#;None times
@@ -155,7 +155,7 @@
(def: #hidden (try-body lazy-body)
(-> (IO Test) Test)
- (case (host;try (io;run lazy-body))
+ (case (_lux_proc ["lux" "try"] [lazy-body])
(#;Right output)
output
diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux
index 9516ae317..92ed5e2ca 100644
--- a/stdlib/test/test/lux.lux
+++ b/stdlib/test/test/lux.lux
@@ -115,10 +115,10 @@
(|> x' (/ y) (* y) (= x'))))
))]
- ["Nat" R;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id]
- ["Int" R;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id]
- ["Real" R;real r.= r.+ r.- r.* r./ r.% r.> 0.0 1.0 1000000.0 %r id math;floor]
- ["Deg" R;deg d.= d.+ d.- d.* d./ d.% d.> .0 (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "max-value"] []) %f id id]
+ ["Nat" R;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id]
+ ["Int" R;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id]
+ ["Real" R;real r.= r.+ r.- r.* r./ r.% r.> 0.0 1.0 1000000.0 %r id math;floor]
+ ["Deg" R;deg d.= d.+ d.- d.* d./ d.% d.> .0 (_lux_proc ["deg" "max-value"] []) (_lux_proc ["deg" "max-value"] []) %f id id]
)
(do-template [category rand-gen -> <- = <cap> %a %z]
@@ -128,10 +128,10 @@
(assert ""
(|> value -> <- (= value))))]
- ["Int->Nat" R;int int-to-nat nat-to-int i.= (i.% 1000000) %i %n]
- ["Nat->Int" R;nat nat-to-int int-to-nat n.= (n.% +1000000) %n %i]
- ["Int->Real" R;int int-to-real real-to-int i.= (i.% 1000000) %i %r]
- ["Real->Int" R;real real-to-int int-to-real r.= math;floor %r %i]
+ ["Int->Nat" R;int int-to-nat nat-to-int i.= (i.% 1000000) %i %n]
+ ["Nat->Int" R;nat nat-to-int int-to-nat n.= (n.% +1000000) %n %i]
+ ["Int->Real" R;int int-to-real real-to-int i.= (i.% 1000000) %i %r]
+ ["Real->Int" R;real real-to-int int-to-real r.= math;floor %r %i]
## [R;real real-to-deg deg-to-real r.= (r.% 1.0) %r %f]
)
diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux
index 67332f282..88a5d86ae 100644
--- a/stdlib/test/test/lux/data/char.lux
+++ b/stdlib/test/test/lux/data/char.lux
@@ -6,8 +6,7 @@
[text]
text/format)
["R" random]
- pipe
- [host #- try])
+ pipe)
lux/test)
(test: "Char operations"
diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux
index fd847001e..883ff0b2b 100644
--- a/stdlib/test/test/lux/data/text.lux
+++ b/stdlib/test/test/lux/data/text.lux
@@ -32,10 +32,10 @@
(&;nth idx)
(case> (^=> (#;Some char)
[(char;as-text char) char']
- [[(&;index-of char' sample)
- (&;last-index-of char' sample)
- (&;index-of' char' idx sample)
- (&;last-index-of' char' idx sample)]
+ [[(&;index-of' char' sample)
+ (&;last-index-of' char' sample)
+ (&;index-of char' idx sample)
+ (&;last-index-of char' idx sample)]
[(#;Some io) (#;Some lio)
(#;Some io') (#;Some lio')]])
(and (n.<= idx io)
@@ -77,10 +77,10 @@
_
false))
- (|> [(&;sub +0 sizeL sample)
- (&;sub sizeL (&;size sample) sample)
- (&;sub' sizeL sample)
- (&;sub' +0 sample)]
+ (|> [(&;clip +0 sizeL sample)
+ (&;clip sizeL (&;size sample) sample)
+ (&;clip' sizeL sample)
+ (&;clip' +0 sample)]
(case> [(#;Right _l) (#;Right _r) (#;Right _r') (#;Right _f)]
(and (= sampleL _l)
(= sampleR _r)
diff --git a/stdlib/test/test/lux/host.js.lux b/stdlib/test/test/lux/host.js.lux
new file mode 100644
index 000000000..4c2b55485
--- /dev/null
+++ b/stdlib/test/test/lux/host.js.lux
@@ -0,0 +1,32 @@
+(;module:
+ lux
+ (lux [io]
+ (control monad)
+ (data text/format)
+ ["&" host]
+ ["R" random]
+ pipe)
+ lux/test)
+
+(test: "JavaScript operations"
+ ($_ seq
+ (assert "Null equals itself."
+ (is (&;null) (&;null)))
+
+ (assert "Undefined equals itself."
+ (is (&;undef) (&;undef)))
+
+ (assert "Can reference JavaScript objects."
+ (is (&;ref "Math") (&;ref "Math")))
+
+ (assert "Can create objects and access their fields."
+ (|> (&;object "foo" "BAR")
+ (&;get "foo" Text)
+ (is "BAR")))
+
+ (assert "Can call JavaScript functions"
+ (and (is 124.0
+ (&;call! (&;ref "Math.ceil" &;Function) [123.45] Real))
+ (is 124.0
+ (&;call! (&;ref "Math") "ceil" [123.45] Real))))
+ ))
diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.jvm.lux
index 54e6cf4b9..54e6cf4b9 100644
--- a/stdlib/test/test/lux/host.lux
+++ b/stdlib/test/test/lux/host.jvm.lux
diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux
index 18cb1545c..769a6f889 100644
--- a/stdlib/test/test/lux/math.lux
+++ b/stdlib/test/test/lux/math.lux
@@ -35,9 +35,6 @@
## (assert "Tangent and arc-tangent are inverse functions."
## (|> angle &;tan &;atan (within? margin angle)))
-
-## (assert "Can freely go between degrees and radians."
-## (|> angle &;degrees &;radians (within? margin angle)))
## ))
(test: "Roots"
diff --git a/stdlib/test/test/lux/math/complex.lux b/stdlib/test/test/lux/math/complex.lux
index 04ebcb3c0..f965f9214 100644
--- a/stdlib/test/test/lux/math/complex.lux
+++ b/stdlib/test/test/lux/math/complex.lux
@@ -54,8 +54,8 @@
(r.= imaginary (get@ #&;imaginary r+i)))))
(assert "If either the real part or the imaginary part is NaN, the composite is NaN."
- (and (&;nan? (&;complex number;nan imaginary))
- (&;nan? (&;complex real number;nan))))
+ (and (&;not-a-number? (&;complex number;not-a-number imaginary))
+ (&;not-a-number? (&;complex real number;not-a-number))))
))
(test: "Absolute value"
@@ -69,14 +69,14 @@
(r.>= (r/abs imaginary) abs))))
(assert "The absolute value of a complex number involving a NaN on either dimension, results in a NaN value."
- (and (number;nan? (get@ #&;real (&;c.abs (&;complex number;nan imaginary))))
- (number;nan? (get@ #&;real (&;c.abs (&;complex real number;nan))))))
+ (and (number;not-a-number? (get@ #&;real (&;c.abs (&;complex number;not-a-number imaginary))))
+ (number;not-a-number? (get@ #&;real (&;c.abs (&;complex real number;not-a-number))))))
(assert "The absolute value of a complex number involving an infinity on either dimension, results in an infinite value."
- (and (r.= number;+inf (get@ #&;real (&;c.abs (&;complex number;+inf imaginary))))
- (r.= number;+inf (get@ #&;real (&;c.abs (&;complex real number;+inf))))
- (r.= number;+inf (get@ #&;real (&;c.abs (&;complex number;-inf imaginary))))
- (r.= number;+inf (get@ #&;real (&;c.abs (&;complex real number;-inf))))))
+ (and (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;positive-infinity imaginary))))
+ (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;positive-infinity))))
+ (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex number;negative-infinity imaginary))))
+ (r.= number;positive-infinity (get@ #&;real (&;c.abs (&;complex real number;negative-infinity))))))
))
(test: "Addidion, substraction, multiplication and division"