diff options
Diffstat (limited to 'luxc')
| -rw-r--r-- | luxc/src/lux/analyser.clj | 5 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/jvm.clj | 73 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/proc.clj | 285 | ||||
| -rw-r--r-- | luxc/src/lux/base.clj | 113 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js.clj | 22 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/base.clj | 3 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/lux.clj | 169 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/proc.clj | 364 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm/host.clj | 104 |
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) ) |