aboutsummaryrefslogtreecommitdiff
path: root/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser.clj5
-rw-r--r--luxc/src/lux/analyser/jvm.clj73
-rw-r--r--luxc/src/lux/analyser/proc.clj285
-rw-r--r--luxc/src/lux/base.clj113
-rw-r--r--luxc/src/lux/compiler/js.clj22
-rw-r--r--luxc/src/lux/compiler/js/base.clj3
-rw-r--r--luxc/src/lux/compiler/js/lux.clj169
-rw-r--r--luxc/src/lux/compiler/js/proc.clj364
-rw-r--r--luxc/src/lux/compiler/jvm/host.clj104
9 files changed, 968 insertions, 170 deletions
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj
index b611c1f80..977911c28 100644
--- a/luxc/src/lux/analyser.clj
+++ b/luxc/src/lux/analyser.clj
@@ -10,6 +10,7 @@
(lux.analyser [base :as &&]
[lux :as &&lux]
[jvm :as &&jvm]
+ [proc :as &&proc]
[module :as &&module]
[parser :as &&a-parser])))
@@ -132,7 +133,9 @@
(&/$Cons [_ (&/$TupleS ?args)]
(&/$Nil))) parameters]
(&/with-analysis-meta cursor exo-type
- (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args)))
+ (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args)
+ ;; (&&proc/analyse-proc analyse exo-type ?category ?proc ?args)
+ ))
"_lux_:"
(|let [(&/$Cons ?type
diff --git a/luxc/src/lux/analyser/jvm.clj b/luxc/src/lux/analyser/jvm.clj
index b82c634d6..6146551ef 100644
--- a/luxc/src/lux/analyser/jvm.clj
+++ b/luxc/src/lux/analyser/jvm.clj
@@ -1068,6 +1068,15 @@
^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool
^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool
+ ;; TODO: USE COMMON PROC ANALYSIS
+ ^: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
@@ -1075,6 +1084,15 @@
^: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
+
+ ;; TODO: USE COMMON PROC ANALYSIS
+ ^: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
)
(defn ^:private analyse-deg-scale [analyse exo-type ?values]
@@ -1105,7 +1123,11 @@
(&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list)))))))))
^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat
+ ;; TODO: USE COMMON PROC ANALYSIS
+ ^: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
+ ;; TODO: USE COMMON PROC ANALYSIS
+ ^:private analyse-real-encode ["real" "encode"] ^:private analyse-real-decode ["real" "decode"] &type/Real
)
(do-template [<name> <type> <op>]
@@ -1119,8 +1141,16 @@
^:private analyse-nat-min-value &type/Nat ["nat" "min-value"]
^:private analyse-nat-max-value &type/Nat ["nat" "max-value"]
+ ;; TODO: USE COMMON PROC ANALYSIS
+ ^: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"]
+
+ ;; TODO: USE COMMON PROC ANALYSIS
+ ^:private analyse-real-min-value &type/Real ["real" "min-value"]
+ ^:private analyse-real-max-value &type/Real ["real" "max-value"]
)
(do-template [<name> <from-type> <to-type> <op>]
@@ -1141,6 +1171,22 @@
^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"]
)
+;; TODO: USE COMMON PROC ANALYSIS
+(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-text-eq ["text" "="] &type/Text &type/Bool
+ ^:private analyse-text-append ["text" "append"] &type/Text &type/Text
+ )
+;; TODO: USE COMMON PROC ANALYSIS
+
(defn analyse-host [analyse exo-type compilers category proc ?values]
(|let [[_ _ _ compile-class compile-interface] compilers]
(case category
@@ -1148,6 +1194,11 @@
(case proc
"==" (analyse-lux-== analyse exo-type ?values))
+ "text"
+ (case proc
+ "=" (analyse-text-eq analyse exo-type ?values)
+ "append" (analyse-text-append analyse exo-type ?values))
+
"bit"
(case proc
"count" (analyse-bit-count analyse exo-type ?values)
@@ -1202,11 +1253,33 @@
"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)
)
"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)
"to-deg" (analyse-real-to-deg analyse exo-type ?values)
)
diff --git a/luxc/src/lux/analyser/proc.clj b/luxc/src/lux/analyser/proc.clj
new file mode 100644
index 000000000..a71a1a9e5
--- /dev/null
+++ b/luxc/src/lux/analyser/proc.clj
@@ -0,0 +1,285 @@
+(ns lux.analyser.proc
+ (: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-== [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-text-eq ["text" "="] &type/Text &type/Bool
+ ^:private analyse-text-append ["text" "append"] &type/Text &type/Text
+ )
+
+;; (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 <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-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
+ )
+
+(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-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 <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"]
+ )
+
+(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-proc [analyse exo-type category proc ?values]
+ (case category
+ ;; "lux"
+ ;; (case proc
+ ;; "==" (analyse-lux-== analyse exo-type ?values))
+
+ "text"
+ (case proc
+ "=" (analyse-text-eq analyse exo-type ?values)
+ "append" (analyse-text-append 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)
+ )
+
+ "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)
+ )
+
+ "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)
+ ;; "to-deg" (analyse-real-to-real analyse exo-type ?values)
+ )
+
+ ;; "char"
+ ;; (case proc
+ ;; "to-nat" (analyse-char-to-nat analyse exo-type ?values)
+ ;; )
+
+ ;; else
+ (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))
diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj
index 6ab09166e..1c34926aa 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))))
@@ -1019,13 +1024,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
@@ -1037,58 +1042,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)
diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj
index 8901bc154..6aa5d5915 100644
--- a/luxc/src/lux/compiler/js.clj
+++ b/luxc/src/lux/compiler/js.clj
@@ -22,7 +22,7 @@
;; [cache :as &&cache]
[lux :as &&lux]
[rt :as &&rt]
- ;; [host :as &&host]
+ [proc :as &&proc]
)
)
(:import (jdk.nashorn.api.scripting NashornScriptEngineFactory
@@ -62,8 +62,8 @@
(&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/$captured ?scope ?captured-id ?source)
+ (&&lux/compile-captured compile-expression ?scope ?captured-id ?source)
(&o/$var (&/$Global ?module ?name))
(&&lux/compile-global ?module ?name)
@@ -74,8 +74,8 @@
;; (&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/$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)
@@ -86,11 +86,11 @@
(&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/$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/$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)
@@ -98,8 +98,8 @@
(&o/$ann ?value-ex ?type-ex)
(compile-expression ?value-ex)
- ;; (&o/$proc [?proc-category ?proc-name] ?args special-args)
- ;; (&&host/compile-host compile-expression ?proc-category ?proc-name ?args special-args)
+ (&o/$proc [?proc-category ?proc-name] ?args special-args)
+ (&&proc/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)
_
(assert false (prn-str 'JS=compile-expression (&/adt->text syntax))))
diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj
index f89bbb9a2..b88d4dc00 100644
--- a/luxc/src/lux/compiler/js/base.clj
+++ b/luxc/src/lux/compiler/js/base.clj
@@ -93,6 +93,9 @@
(instance? java.lang.String js-object))
js-object
+ (instance? java.lang.Number js-object)
+ (long js-object)
+
(instance? LuxJsObject js-object)
(.-obj ^LuxJsObject js-object)
diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj
index 3324a83c7..578eb74f8 100644
--- a/luxc/src/lux/compiler/js/lux.clj
+++ b/luxc/src/lux/compiler/js/lux.clj
@@ -22,6 +22,9 @@
(defn ^:private js-var-name [module name]
(str (string/replace module "/" "$") "$" (&host/def-name name)))
+(defn ^:private captured-name [register]
+ (str "$" register))
+
(defn ^:private register-name [register]
(str "_" register))
@@ -31,7 +34,7 @@
(do-template [<name>]
(defn <name> [value]
- (return (str value "|0")))
+ (return (str "(" value "|0)")))
compile-nat
compile-int
@@ -70,16 +73,8 @@
(defn compile-local [compile register]
(return (register-name register)))
-;; (defn compile-captured [compile ?scope ?captured-id ?source]
-;; (|do [:let [??scope (&/|reverse ?scope)]
-;; ^MethodVisitor *writer* &/get-writer
-;; :let [_ (doto *writer*
-;; (.visitVarInsn Opcodes/ALOAD 0)
-;; (.visitFieldInsn Opcodes/GETFIELD
-;; (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope)))
-;; (str &&/closure-prefix ?captured-id)
-;; "Ljava/lang/Object;"))]]
-;; (return nil)))
+(defn compile-captured [compile ?scope ?captured-id ?source]
+ (return (captured-name ?captured-id)))
(defn compile-global [module name]
(return (js-var-name module name)))
@@ -105,38 +100,31 @@
;; (compile-expression $begin body)
;; ))
-;; (defn compile-iter [compile $begin register-offset ?args]
-;; (|do [^MethodVisitor *writer* &/get-writer
-;; :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args)))
-;; ?args)]
-;; _ (&/map% (fn [idx+?arg]
-;; (|do [:let [[idx ?arg] idx+?arg
-;; idx+ (+ register-offset idx)
-;; already-set? (|case ?arg
-;; [_ (&o/$var (&/$Local l-idx))]
-;; (= idx+ l-idx)
-
-;; _
-;; false)]]
-;; (if already-set?
-;; (return nil)
-;; (compile ?arg))))
-;; idxs+args)
-;; _ (&/map% (fn [idx+?arg]
-;; (|do [:let [[idx ?arg] idx+?arg
-;; idx+ (+ register-offset idx)
-;; already-set? (|case ?arg
-;; [_ (&o/$var (&/$Local l-idx))]
-;; (= idx+ l-idx)
-
-;; _
-;; false)]
-;; :let [_ (when (not already-set?)
-;; (.visitVarInsn *writer* Opcodes/ASTORE idx+))]]
-;; (return nil)))
-;; (&/|reverse idxs+args))
-;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]]
-;; (return nil)))
+(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 "_0("
+ (->> =args (&/|interpose ",") (&/fold str ""))
+ ")")))
+ )
(defn compile-let [compile _value _register _body]
(|do [=value (compile _value)
@@ -146,35 +134,20 @@
" return " =body
";})()"))))
-;; (defn compile-record-get [compile _value _path]
-;; (|do [^MethodVisitor *writer* &/get-writer
-;; _ (compile _value)
-;; :let [_ (&/|map (fn [step]
-;; (|let [[idx tail?] step]
-;; (doto *writer*
-;; (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
-;; (.visitLdcInsn (int idx))
-;; (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT"
-;; (if tail? "product_getRight" "product_getLeft")
-;; "([Ljava/lang/Object;I)Ljava/lang/Object;"))))
-;; _path)]]
-;; (return nil)))
-
-;; (defn compile-if [compile _test _then _else]
-;; (|do [^MethodVisitor *writer* &/get-writer
-;; _ (compile _test)
-;; :let [$else (new Label)
-;; $end (new Label)
-;; _ (doto *writer*
-;; &&/unwrap-boolean
-;; (.visitJumpInsn Opcodes/IFEQ $else))]
-;; _ (compile _then)
-;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]
-;; :let [_ (.visitLabel *writer* $else)]
-;; _ (compile _else)
-;; :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)
-;; _ (.visitLabel *writer* $end)]]
-;; (return nil)))
+(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 &&rt/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")
@@ -307,27 +280,39 @@
func-args (->> (&/|range* 0 (dec arity))
(&/|map (fn [register] (str "var " (register-name (inc register)) " = arguments[" register "];")))
(&/fold str ""))]
+ =env (&/map% (fn [=captured]
+ (|case =captured
+ [_ (&o/$captured ?scope ?captured-id ?source)]
+ (|do [=source (compile ?source)]
+ (return (str "var " (captured-name ?captured-id) " = " =source ";")))))
+ (&/|vals ?env))
=body (compile ?body)]
- (return (str "(function " function-name "() {"
- "\"use strict\";"
- "var num_args = arguments.length;"
- "if(num_args == " arity ") {"
- "var " (register-name 0) " = " function-name ";"
- func-args
- "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)));"
- " };"
- "}"
- "})"))))
+ (return (str "(function() {"
+ (->> =env (&/fold str ""))
+ "return "
+ (str "(function " function-name "() {"
+ "\"use strict\";"
+ "var num_args = arguments.length;"
+ "if(num_args == " arity ") {"
+ "var " (register-name 0) " = " 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)));"
+ " };"
+ "}"
+ "})")
+ ";})()"))))
(defn compile-def [compile ?name ?body def-meta]
(|do [module-name &/get-module-name
diff --git a/luxc/src/lux/compiler/js/proc.clj b/luxc/src/lux/compiler/js/proc.clj
new file mode 100644
index 000000000..95e6950da
--- /dev/null
+++ b/luxc/src/lux/compiler/js/proc.clj
@@ -0,0 +1,364 @@
+(ns lux.compiler.js.proc
+ (: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 &&]))
+
+;; [Resources]
+;; (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]
+ =x (compile ?x)
+ =y (compile ?y)]
+ (return (str "(" =x " " <opcode> " " =y ")"))))
+
+ ^:private compile-nat-add "+"
+ ^:private compile-nat-sub "-"
+ ^:private compile-nat-mul "*"
+ ^:private compile-nat-div "/"
+ ^:private compile-nat-rem "%"
+ ^:private compile-nat-eq "==="
+ ^:private compile-nat-lt "<"
+
+ ^:private compile-int-add "+"
+ ^:private compile-int-sub "-"
+ ^:private compile-int-mul "*"
+ ^:private compile-int-div "/"
+ ^:private compile-int-rem "%"
+ ^:private compile-int-eq "==="
+ ^:private compile-int-lt "<"
+
+ ^:private compile-deg-add "+"
+ ^:private compile-deg-sub "-"
+ ^:private compile-deg-mul "*"
+ ^:private compile-deg-div "/"
+ ^:private compile-deg-rem "%"
+ ^:private compile-deg-eq "==="
+ ^:private compile-deg-lt "<"
+ ^:private compile-deg-scale "*"
+
+ ^: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 "<"
+ )
+
+;; (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"
+;; )
+
+(defn compile-int-encode [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str "(" =x ").toString()"))))
+
+;; (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]]
+ (compile ?x)))
+
+ ^:private compile-nat-to-int
+ ^:private compile-int-to-nat
+ )
+
+(defn compile-text-eq [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
+ =x (compile ?x)
+ =y (compile ?y)]
+ (return (str "(" =x "===" =y ")"))))
+
+(defn 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 ")"))))
+
+(defn compile-proc [compile proc-category proc-name ?values special-args]
+ (case proc-category
+ ;; "lux"
+ ;; (case proc-name
+ ;; "==" (compile-lux-== compile ?values special-args))
+
+ "text"
+ (case proc-name
+ "=" (compile-text-eq compile ?values special-args)
+ "append" (compile-text-append 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)
+ )
+
+ "int"
+ (case proc-name
+ "+" (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)
+ )
+
+ "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)
+ )
+
+ "real"
+ (case proc-name
+ "+" (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)
+ ;; "to-deg" (compile-real-to-deg compile ?values special-args)
+ )
+
+ ;; "char"
+ ;; (case proc-name
+ ;; "to-nat" (compile-char-to-nat compile ?values special-args)
+ ;; )
+
+ ;; else
+ (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " [proc-category proc-name]))))
diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj
index 34a5a2bb7..9583c3106 100644
--- a/luxc/src/lux/compiler/jvm/host.clj
+++ b/luxc/src/lux/compiler/jvm/host.clj
@@ -1954,6 +1954,12 @@
(.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
+
^: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
@@ -2383,29 +2389,41 @@
(.visitLabel $end))]]
(return nil)))
-(do-template [<name> <opcode>]
+(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-long)]
+ <unwrap>)]
_ (compile ?y)
:let [_ (doto *writer*
- &&/unwrap-long)
+ <unwrap>)
_ (doto *writer*
(.visitInsn <opcode>)
- &&/wrap-long)]]
+ <wrap>)]]
(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
+ ^: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>]
@@ -2518,6 +2536,24 @@
^:private compile-deg-encode "encode_deg" ^:private compile-deg-decode "decode_deg"
)
+(defn ^:private compile-int-encode [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;"))]]
+ (return nil)))
+
+(defn ^:private compile-real-encode [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ &&/unwrap-double
+ (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Double" "toString" "(D)Ljava/lang/String;"))]]
+ (return nil)))
+
(do-template [<name> <method>]
(defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
@@ -2586,11 +2622,39 @@
^:private compile-int-to-nat
)
+(defn 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 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-host [compile proc-category proc-name ?values special-args]
(case proc-category
"lux"
(case proc-name
"==" (compile-lux-== compile ?values special-args))
+
+ "text"
+ (case proc-name
+ "=" (compile-text-eq compile ?values special-args)
+ "append" (compile-text-append compile ?values special-args))
"bit"
(case proc-name
@@ -2642,11 +2706,27 @@
"int"
(case proc-name
+ "+" (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)
"to-nat" (compile-int-to-nat compile ?values special-args)
+ "encode" (compile-int-encode compile ?values special-args)
)
"real"
(case proc-name
+ "+" (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)
"to-deg" (compile-real-to-deg compile ?values special-args)
)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 09:24:50 +0000