diff options
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 &¶llel]) - (lux.compiler.cache [type :as &&&type] - [ann :as &&&ann])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) + [parallel :as &¶llel] + [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) (&¶llel/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!! (&¶llel/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 &¶llel] + [cache :as &&cache]) + (lux.compiler.js [base :as &&] + [lux :as &&lux] + [rt :as &&rt] + [cache :as &&js-cache]) + (lux.compiler.js.proc [common :as &&common] + [host :as &&host]) + ) + (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory + NashornScriptEngine + ScriptObjectMirror) + (jdk.nashorn.internal.runtime Undefined)) + ) + +;; [Resources] +(defn ^:private compile-expression [syntax] + (|let [[[?type [_file-name _line _]] ?form] syntax] + (|case ?form + (&o/$bool ?value) + (&&lux/compile-bool ?value) + + (&o/$nat ?value) + (&&lux/compile-nat ?value) + + (&o/$int ?value) + (&&lux/compile-int ?value) + + (&o/$deg ?value) + (&&lux/compile-deg ?value) + + (&o/$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!! (&¶llel/parallel-compilation (partial compile-module source-dirs))]] + (&/|eitherL (|do [output (&&cache/load name) + ^StringBuilder total-buffer &&/get-total-buffer + :let [module-code-path (str @&&core/!output-dir java.io.File/separator name java.io.File/separator &&/module-js-name) + _ (.append total-buffer ^String (str (slurp module-code-path) "\n"))]] + (return output)) + (let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (&/fail-with-loc (str "[Compiler Error] 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 &¶llel]) + (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!! (&¶llel/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" |