diff options
author | Eduardo Julian | 2017-02-07 19:38:58 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-02-07 19:38:58 -0400 |
commit | 66ceed37b71921e14cae8a091df7738d9e587c2d (patch) | |
tree | e1f1428783d93d57383f1055a0e3fe2ca90f3dc7 /luxc/src | |
parent | 8003120870b877264afcfc5bc785453ae55e2a7b (diff) |
- Reorganized the code related to _lux_proc a bit.
- Implemented some of the low-level machinery for 64-bit integers.
Diffstat (limited to '')
-rw-r--r-- | luxc/src/lux/analyser.clj | 13 | ||||
-rw-r--r-- | luxc/src/lux/analyser/proc/common.clj (renamed from luxc/src/lux/analyser/proc.clj) | 133 | ||||
-rw-r--r-- | luxc/src/lux/analyser/proc/jvm.clj (renamed from luxc/src/lux/analyser/jvm.clj) | 568 | ||||
-rw-r--r-- | luxc/src/lux/base.clj | 10 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js.clj | 14 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/base.clj | 56 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/lux.clj | 6 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/proc/common.clj (renamed from luxc/src/lux/compiler/js/proc.clj) | 83 | ||||
-rw-r--r-- | luxc/src/lux/compiler/js/rt.clj | 173 | ||||
-rw-r--r-- | luxc/src/lux/type.clj | 16 |
10 files changed, 465 insertions, 607 deletions
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 977911c28..f5a200cad 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -9,10 +9,10 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [jvm :as &&jvm] - [proc :as &&proc] [module :as &&module] - [parser :as &&a-parser]))) + [parser :as &&a-parser]) + (lux.analyser.proc [common :as &&common] + [jvm :as &&jvm]))) ;; [Utils] (defn analyse-variant+ [analyse exo-type ident values] @@ -133,8 +133,11 @@ (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))) parameters] (&/with-analysis-meta cursor exo-type - (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) - ;; (&&proc/analyse-proc analyse exo-type ?category ?proc ?args) + (case ?category + "jvm" (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args) + ;; "js" + ;; common + (&&common/analyse-proc analyse exo-type ?category ?proc ?args)) )) "_lux_:" diff --git a/luxc/src/lux/analyser/proc.clj b/luxc/src/lux/analyser/proc/common.clj index a71a1a9e5..f6d1eef8e 100644 --- a/luxc/src/lux/analyser/proc.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -1,4 +1,4 @@ -(ns lux.analyser.proc +(ns lux.analyser.proc.common (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array @@ -31,43 +31,43 @@ ^: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> <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] @@ -161,6 +161,9 @@ ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + + ^:private analyse-real-min-value &type/Real ["real" "min-value"] + ^:private analyse-real-max-value &type/Real ["real" "max-value"] ) (do-template [<name> <from-type> <to-type> <op>] @@ -183,24 +186,24 @@ (defn analyse-proc [analyse exo-type category proc ?values] (case category - ;; "lux" - ;; (case proc - ;; "==" (analyse-lux-== analyse exo-type ?values)) + "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)) + "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 @@ -208,7 +211,7 @@ ;; "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)) + ;; "size" (analyse-array-size analyse exo-type ?values)) "nat" (case proc @@ -252,12 +255,12 @@ "%" (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) + "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" @@ -270,16 +273,16 @@ "=" (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) + "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) ) - ;; "char" - ;; (case proc - ;; "to-nat" (analyse-char-to-nat 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/analyser/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj index 6146551ef..480cb341a 100644 --- a/luxc/src/lux/analyser/jvm.clj +++ b/luxc/src/lux/analyser/proc/jvm.clj @@ -1,4 +1,4 @@ -(ns lux.analyser.jvm +(ns lux.analyser.proc.jvm (:require (clojure [template :refer [do-template]] [string :as string]) clojure.core.match @@ -1001,432 +1001,144 @@ ))) )))) -(do-template [<name> <op>] - (defn <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse &type/Nat mask) - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" <op>]) (&/|list =input =mask) (&/|list))))))) - - ^:private analyse-bit-and "and" - ^:private analyse-bit-or "or" - ^:private analyse-bit-xor "xor" - ) - -(defn ^:private analyse-bit-count [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Nil)) ?values] - =input (&&/analyse-1 analyse &type/Nat input) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) - -(do-template [<name> <op> <type>] - (defn <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse <type> input) - _ (&type/check exo-type <type>) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list))))))) - - ^:private analyse-bit-shift-left "shift-left" &type/Nat - ^:private analyse-bit-shift-right "shift-right" &type/Int - ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat - ) - -(defn ^:private analyse-lux-== [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Cons left (&/$Cons right (&/$Nil))) ?values] - =left (&&/analyse-1 analyse $var left) - =right (&&/analyse-1 analyse $var right) - _ (&type/check exo-type &type/Bool) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["lux" "=="]) (&/|list =left =right) (&/|list))))))))) - -(do-template [<name> <proc> <input-type> <output-type>] - (defn <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] - =x (&&/analyse-1 analyse <input-type> x) - =y (&&/analyse-1 analyse <input-type> y) - _ (&type/check exo-type <output-type>) - _cursor &/cursor] - (return (&/|list (&&/|meta <output-type> _cursor - (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat - ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat - ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat - ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat - ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat - ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool - ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool - - ;; 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 - ^: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 - - ;; 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] - (|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 - ;; 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>] - (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"] - - ;; 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>] - (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"] - ) - -;; 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] +(defn analyse-host [analyse exo-type compilers proc ?values] (|let [[_ _ _ compile-class compile-interface] compilers] - (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) - ) - - "deg" - (case proc - "+" (analyse-deg-add analyse exo-type ?values) - "-" (analyse-deg-sub analyse exo-type ?values) - "*" (analyse-deg-mul analyse exo-type ?values) - "/" (analyse-deg-div analyse exo-type ?values) - "%" (analyse-deg-rem analyse exo-type ?values) - "=" (analyse-deg-eq analyse exo-type ?values) - "<" (analyse-deg-lt analyse exo-type ?values) - "encode" (analyse-deg-encode analyse exo-type ?values) - "decode" (analyse-deg-decode analyse exo-type ?values) - "min-value" (analyse-deg-min-value analyse exo-type ?values) - "max-value" (analyse-deg-max-value analyse exo-type ?values) - "to-real" (analyse-deg-to-real analyse exo-type ?values) - "scale" (analyse-deg-scale analyse exo-type ?values) - ) - - "int" - (case proc - "+" (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) - ) - - "char" - (case proc - "to-nat" (analyse-char-to-nat analyse exo-type ?values) - ) - - "jvm" - (case proc - "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) - "load-class" (analyse-jvm-load-class analyse exo-type ?values) - "try" (analyse-jvm-try analyse exo-type ?values) - "throw" (analyse-jvm-throw analyse exo-type ?values) - "null?" (analyse-jvm-null? analyse exo-type ?values) - "null" (analyse-jvm-null analyse exo-type ?values) - "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "aaload" (analyse-jvm-aaload analyse exo-type ?values) - "aastore" (analyse-jvm-aastore analyse exo-type ?values) - "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "iadd" (analyse-jvm-iadd analyse exo-type ?values) - "isub" (analyse-jvm-isub analyse exo-type ?values) - "imul" (analyse-jvm-imul analyse exo-type ?values) - "idiv" (analyse-jvm-idiv analyse exo-type ?values) - "irem" (analyse-jvm-irem analyse exo-type ?values) - "ieq" (analyse-jvm-ieq analyse exo-type ?values) - "ilt" (analyse-jvm-ilt analyse exo-type ?values) - "igt" (analyse-jvm-igt analyse exo-type ?values) - "ceq" (analyse-jvm-ceq analyse exo-type ?values) - "clt" (analyse-jvm-clt analyse exo-type ?values) - "cgt" (analyse-jvm-cgt analyse exo-type ?values) - "ladd" (analyse-jvm-ladd analyse exo-type ?values) - "lsub" (analyse-jvm-lsub analyse exo-type ?values) - "lmul" (analyse-jvm-lmul analyse exo-type ?values) - "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "lrem" (analyse-jvm-lrem analyse exo-type ?values) - "leq" (analyse-jvm-leq analyse exo-type ?values) - "llt" (analyse-jvm-llt analyse exo-type ?values) - "lgt" (analyse-jvm-lgt analyse exo-type ?values) - "fadd" (analyse-jvm-fadd analyse exo-type ?values) - "fsub" (analyse-jvm-fsub analyse exo-type ?values) - "fmul" (analyse-jvm-fmul analyse exo-type ?values) - "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "frem" (analyse-jvm-frem analyse exo-type ?values) - "feq" (analyse-jvm-feq analyse exo-type ?values) - "flt" (analyse-jvm-flt analyse exo-type ?values) - "fgt" (analyse-jvm-fgt analyse exo-type ?values) - "dadd" (analyse-jvm-dadd analyse exo-type ?values) - "dsub" (analyse-jvm-dsub analyse exo-type ?values) - "dmul" (analyse-jvm-dmul analyse exo-type ?values) - "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "drem" (analyse-jvm-drem analyse exo-type ?values) - "deq" (analyse-jvm-deq analyse exo-type ?values) - "dlt" (analyse-jvm-dlt analyse exo-type ?values) - "dgt" (analyse-jvm-dgt analyse exo-type ?values) - "iand" (analyse-jvm-iand analyse exo-type ?values) - "ior" (analyse-jvm-ior analyse exo-type ?values) - "ixor" (analyse-jvm-ixor analyse exo-type ?values) - "ishl" (analyse-jvm-ishl analyse exo-type ?values) - "ishr" (analyse-jvm-ishr analyse exo-type ?values) - "iushr" (analyse-jvm-iushr analyse exo-type ?values) - "land" (analyse-jvm-land analyse exo-type ?values) - "lor" (analyse-jvm-lor analyse exo-type ?values) - "lxor" (analyse-jvm-lxor analyse exo-type ?values) - "lshl" (analyse-jvm-lshl analyse exo-type ?values) - "lshr" (analyse-jvm-lshr analyse exo-type ?values) - "lushr" (analyse-jvm-lushr analyse exo-type ?values) - "d2f" (analyse-jvm-d2f analyse exo-type ?values) - "d2i" (analyse-jvm-d2i analyse exo-type ?values) - "d2l" (analyse-jvm-d2l analyse exo-type ?values) - "f2d" (analyse-jvm-f2d analyse exo-type ?values) - "f2i" (analyse-jvm-f2i analyse exo-type ?values) - "f2l" (analyse-jvm-f2l analyse exo-type ?values) - "i2b" (analyse-jvm-i2b analyse exo-type ?values) - "i2c" (analyse-jvm-i2c analyse exo-type ?values) - "i2d" (analyse-jvm-i2d analyse exo-type ?values) - "i2f" (analyse-jvm-i2f analyse exo-type ?values) - "i2l" (analyse-jvm-i2l analyse exo-type ?values) - "i2s" (analyse-jvm-i2s analyse exo-type ?values) - "l2d" (analyse-jvm-l2d analyse exo-type ?values) - "l2f" (analyse-jvm-l2f analyse exo-type ?values) - "l2i" (analyse-jvm-l2i analyse exo-type ?values) - "l2s" (analyse-jvm-l2s analyse exo-type ?values) - "l2b" (analyse-jvm-l2b analyse exo-type ?values) - "c2b" (analyse-jvm-c2b analyse exo-type ?values) - "c2s" (analyse-jvm-c2s analyse exo-type ?values) - "c2i" (analyse-jvm-c2i analyse exo-type ?values) - "c2l" (analyse-jvm-c2l analyse exo-type ?values) - "b2l" (analyse-jvm-b2l analyse exo-type ?values) - "s2l" (analyse-jvm-s2l analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])) - (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] - (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) - - (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] - (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) - - (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] - (|do [[_module _line _column] &/cursor] - (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] - (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) - - (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - + (case proc + "synchronized" (analyse-jvm-synchronized analyse exo-type ?values) + "load-class" (analyse-jvm-load-class analyse exo-type ?values) + "try" (analyse-jvm-try analyse exo-type ?values) + "throw" (analyse-jvm-throw analyse exo-type ?values) + "null?" (analyse-jvm-null? analyse exo-type ?values) + "null" (analyse-jvm-null analyse exo-type ?values) + "anewarray" (analyse-jvm-anewarray analyse exo-type ?values) + "aaload" (analyse-jvm-aaload analyse exo-type ?values) + "aastore" (analyse-jvm-aastore analyse exo-type ?values) + "arraylength" (analyse-jvm-arraylength analyse exo-type ?values) + "znewarray" (analyse-jvm-znewarray analyse exo-type ?values) + "bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) + "snewarray" (analyse-jvm-snewarray analyse exo-type ?values) + "inewarray" (analyse-jvm-inewarray analyse exo-type ?values) + "lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) + "fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) + "dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) + "cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) + "iadd" (analyse-jvm-iadd analyse exo-type ?values) + "isub" (analyse-jvm-isub analyse exo-type ?values) + "imul" (analyse-jvm-imul analyse exo-type ?values) + "idiv" (analyse-jvm-idiv analyse exo-type ?values) + "irem" (analyse-jvm-irem analyse exo-type ?values) + "ieq" (analyse-jvm-ieq analyse exo-type ?values) + "ilt" (analyse-jvm-ilt analyse exo-type ?values) + "igt" (analyse-jvm-igt analyse exo-type ?values) + "ceq" (analyse-jvm-ceq analyse exo-type ?values) + "clt" (analyse-jvm-clt analyse exo-type ?values) + "cgt" (analyse-jvm-cgt analyse exo-type ?values) + "ladd" (analyse-jvm-ladd analyse exo-type ?values) + "lsub" (analyse-jvm-lsub analyse exo-type ?values) + "lmul" (analyse-jvm-lmul analyse exo-type ?values) + "ldiv" (analyse-jvm-ldiv analyse exo-type ?values) + "lrem" (analyse-jvm-lrem analyse exo-type ?values) + "leq" (analyse-jvm-leq analyse exo-type ?values) + "llt" (analyse-jvm-llt analyse exo-type ?values) + "lgt" (analyse-jvm-lgt analyse exo-type ?values) + "fadd" (analyse-jvm-fadd analyse exo-type ?values) + "fsub" (analyse-jvm-fsub analyse exo-type ?values) + "fmul" (analyse-jvm-fmul analyse exo-type ?values) + "fdiv" (analyse-jvm-fdiv analyse exo-type ?values) + "frem" (analyse-jvm-frem analyse exo-type ?values) + "feq" (analyse-jvm-feq analyse exo-type ?values) + "flt" (analyse-jvm-flt analyse exo-type ?values) + "fgt" (analyse-jvm-fgt analyse exo-type ?values) + "dadd" (analyse-jvm-dadd analyse exo-type ?values) + "dsub" (analyse-jvm-dsub analyse exo-type ?values) + "dmul" (analyse-jvm-dmul analyse exo-type ?values) + "ddiv" (analyse-jvm-ddiv analyse exo-type ?values) + "drem" (analyse-jvm-drem analyse exo-type ?values) + "deq" (analyse-jvm-deq analyse exo-type ?values) + "dlt" (analyse-jvm-dlt analyse exo-type ?values) + "dgt" (analyse-jvm-dgt analyse exo-type ?values) + "iand" (analyse-jvm-iand analyse exo-type ?values) + "ior" (analyse-jvm-ior analyse exo-type ?values) + "ixor" (analyse-jvm-ixor analyse exo-type ?values) + "ishl" (analyse-jvm-ishl analyse exo-type ?values) + "ishr" (analyse-jvm-ishr analyse exo-type ?values) + "iushr" (analyse-jvm-iushr analyse exo-type ?values) + "land" (analyse-jvm-land analyse exo-type ?values) + "lor" (analyse-jvm-lor analyse exo-type ?values) + "lxor" (analyse-jvm-lxor analyse exo-type ?values) + "lshl" (analyse-jvm-lshl analyse exo-type ?values) + "lshr" (analyse-jvm-lshr analyse exo-type ?values) + "lushr" (analyse-jvm-lushr analyse exo-type ?values) + "d2f" (analyse-jvm-d2f analyse exo-type ?values) + "d2i" (analyse-jvm-d2i analyse exo-type ?values) + "d2l" (analyse-jvm-d2l analyse exo-type ?values) + "f2d" (analyse-jvm-f2d analyse exo-type ?values) + "f2i" (analyse-jvm-f2i analyse exo-type ?values) + "f2l" (analyse-jvm-f2l analyse exo-type ?values) + "i2b" (analyse-jvm-i2b analyse exo-type ?values) + "i2c" (analyse-jvm-i2c analyse exo-type ?values) + "i2d" (analyse-jvm-i2d analyse exo-type ?values) + "i2f" (analyse-jvm-i2f analyse exo-type ?values) + "i2l" (analyse-jvm-i2l analyse exo-type ?values) + "i2s" (analyse-jvm-i2s analyse exo-type ?values) + "l2d" (analyse-jvm-l2d analyse exo-type ?values) + "l2f" (analyse-jvm-l2f analyse exo-type ?values) + "l2i" (analyse-jvm-l2i analyse exo-type ?values) + "l2s" (analyse-jvm-l2s analyse exo-type ?values) + "l2b" (analyse-jvm-l2b analyse exo-type ?values) + "c2b" (analyse-jvm-c2b analyse exo-type ?values) + "c2s" (analyse-jvm-c2s analyse exo-type ?values) + "c2i" (analyse-jvm-c2i analyse exo-type ?values) + "c2l" (analyse-jvm-c2l analyse exo-type ?values) + "b2l" (analyse-jvm-b2l analyse exo-type ?values) + "s2l" (analyse-jvm-s2l analyse exo-type ?values) ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc]))))) + (->> (&/fail-with-loc (str "[Analyser Error] Unknown JVM procedure: " proc)) + (if-let [[_ _def-code] (re-find #"^interface:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] + (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) + + (if-let [[_ _def-code] (re-find #"^class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] + (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) + + (if-let [[_ _def-code] (re-find #"^anon-class:(.*)$" proc)] + (|do [[_module _line _column] &/cursor] + (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code + (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] + (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) + + (if-let [[_ _class] (re-find #"^instanceof:([^:]+)$" proc)] + (analyse-jvm-instanceof analyse exo-type _class ?values)) + + (if-let [[_ _class _arg-classes] (re-find #"^new:([^:]+):([^:]*)$" proc)] + (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _method _arg-classes] (re-find #"^invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] + (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) + + (if-let [[_ _class _field] (re-find #"^getstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^getfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-getfield analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putstatic:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putstatic analyse exo-type _class _field ?values)) + + (if-let [[_ _class _field] (re-find #"^putfield:([^:]+):([^:]+)$" proc)] + (analyse-jvm-putfield analyse exo-type _class _field ?values)))) + )) diff --git a/luxc/src/lux/base.clj b/luxc/src/lux/base.clj index 1c34926aa..f449a7b3c 100644 --- a/luxc/src/lux/base.clj +++ b/luxc/src/lux/base.clj @@ -308,7 +308,7 @@ nil ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) v (recur slot table*)))) @@ -318,7 +318,7 @@ ($Cons (T [slot value]) $Nil) ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) ($Cons (T [slot value]) table*) ($Cons (T [k v]) (|put slot value table*))) )) @@ -329,7 +329,7 @@ table ($Cons [k v] table*) - (if (.equals ^Object k slot) + (if (= k slot) table* ($Cons (T [k v]) (|remove slot table*))))) @@ -339,7 +339,7 @@ table ($Cons [k* v] table*) - (if (.equals ^Object k k*) + (if (= k k*) ($Cons (T [k* (f v)]) table*) ($Cons (T [k* v]) (|update k f table*))))) @@ -465,7 +465,7 @@ false ($Cons [k* _] table*) - (or (.equals ^Object k k*) + (or (= k k*) (|contains? k table*)))) (defn |member? [x xs] diff --git a/luxc/src/lux/compiler/js.clj b/luxc/src/lux/compiler/js.clj index 6aa5d5915..a60afbc23 100644 --- a/luxc/src/lux/compiler/js.clj +++ b/luxc/src/lux/compiler/js.clj @@ -22,8 +22,8 @@ ;; [cache :as &&cache] [lux :as &&lux] [rt :as &&rt] - [proc :as &&proc] ) + (lux.compiler.js.proc [common :as &&common]) ) (:import (jdk.nashorn.api.scripting NashornScriptEngineFactory NashornScriptEngine @@ -99,7 +99,10 @@ (compile-expression ?value-ex) (&o/$proc [?proc-category ?proc-name] ?args special-args) - (&&proc/compile-proc compile-expression ?proc-category ?proc-name ?args special-args) + (case ?proc-category + ;; "js" ... + ;; common + (&&common/compile-proc compile-expression ?proc-category ?proc-name ?args special-args)) _ (assert false (prn-str 'JS=compile-expression (&/adt->text syntax)))) @@ -174,6 +177,7 @@ (&/$Left ?message) (binding [*out* !err!] (do (println (str "Compilation failed:\n" ?message)) - ;; (flush) - ;; (System/exit 1) - ))))))) + (flush) + (System/exit 1) + )) + ))))) diff --git a/luxc/src/lux/compiler/js/base.clj b/luxc/src/lux/compiler/js/base.clj index b88d4dc00..62d440d6d 100644 --- a/luxc/src/lux/compiler/js/base.clj +++ b/luxc/src/lux/compiler/js/base.clj @@ -40,12 +40,6 @@ (def ^:private lux-obj-class (Class/forName "[Ljava.lang.Object;")) -(defn ^:private _valueOf_ [value] - (reify JSObject - (isFunction [self] true) - (call [self this args] - value))) - (defn ^:private _slice_ [wrap-lux-obj value] (reify JSObject (isFunction [self] true) @@ -58,25 +52,43 @@ (isFunction [self] true) (call [self this args] (&/adt->text obj) - ;; (pr-str this) ))) +(def ^:private i64-mask (dec (bit-shift-left 1 32))) +(defn ^:private to-i64 [value] + (reify JSObject + (getMember [self member] + (condp = member + "H" (-> value (unsigned-bit-shift-right 32) (bit-and i64-mask) int) + "L" (-> value (bit-and i64-mask) int) + ;; else + (assert false (str "to-i64#getMember = " member)))))) + (deftype LuxJsObject [obj] JSObject (isFunction [self] false) (getSlot [self idx] (let [value (aget obj idx)] - (if (instance? lux-obj-class value) - (new LuxJsObject value) - value))) + (cond (instance? lux-obj-class value) + (new LuxJsObject value) + + (instance? java.lang.Long value) + (to-i64 value) + + :else + value))) (getMember [self member] (condp = member - ;; "valueOf" (_valueOf_ obj) "toString" (_toString_ obj) "length" (alength obj) - "slice" (let [wrap-lux-obj #(if (instance? lux-obj-class %) - (new LuxJsObject %) - %)] + "slice" (let [wrap-lux-obj #(cond (instance? lux-obj-class %) + (new LuxJsObject %) + + (instance? java.lang.Long %) + (to-i64 %) + + :else + %)] (_slice_ wrap-lux-obj obj)) ;; else (assert false (str "wrap-lux-obj#getMember = " member))))) @@ -86,6 +98,17 @@ (new LuxJsObject obj) obj)) +(defn ^:private int64? [^ScriptObjectMirror js-object] + (and (.hasMember js-object "H") + (.hasMember js-object "L"))) + +(defn ^:private parse-int64 [^ScriptObjectMirror js-object] + (+ (-> (.getMember js-object "H") + long + (bit-shift-left 32)) + (-> (.getMember js-object "L") + long))) + (defn js-to-lux [js-object] (cond (or (nil? js-object) (instance? java.lang.Boolean js-object) @@ -94,7 +117,7 @@ js-object (instance? java.lang.Number js-object) - (long js-object) + (double js-object) (instance? LuxJsObject js-object) (.-obj ^LuxJsObject js-object) @@ -123,6 +146,9 @@ (.isFunction js-object) js-object + (int64? js-object) + (parse-int64 js-object) + :else (assert false (str "Unknown kind of JS object: " js-object)))) diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj index 578eb74f8..a7b1217f0 100644 --- a/luxc/src/lux/compiler/js/lux.clj +++ b/luxc/src/lux/compiler/js/lux.clj @@ -32,9 +32,13 @@ (defn compile-bool [?value] (return (str ?value))) +(def mask-4b (dec (bit-shift-left 1 32))) + (do-template [<name>] (defn <name> [value] - (return (str "(" value "|0)"))) + (let [high (-> value (unsigned-bit-shift-right 32) (bit-and mask-4b)) + low (-> value (bit-and mask-4b))] + (return (str &&rt/LuxRT "." "makeI64" "(" high "," low ")")))) compile-nat compile-int diff --git a/luxc/src/lux/compiler/js/proc.clj b/luxc/src/lux/compiler/js/proc/common.clj index 95e6950da..7e052892b 100644 --- a/luxc/src/lux/compiler/js/proc.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -1,4 +1,4 @@ -(ns lux.compiler.js.proc +(ns lux.compiler.js.proc.common (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) @@ -9,7 +9,8 @@ [analyser :as &analyser] [optimizer :as &o]) [lux.analyser.base :as &a] - [lux.compiler.js.base :as &&])) + (lux.compiler.js [base :as &&] + [rt :as &&rt]))) ;; [Resources] ;; (do-template [<name> <op>] @@ -78,6 +79,39 @@ ;; (.visitLabel $end))]] ;; (return nil))) +(do-template [<name> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str &&rt/LuxRT "." <method> "(" =x "," =y ")")))) + + ^:private compile-nat-add "addI64" + ^:private compile-nat-sub "subI64" + ^:private compile-nat-mul "mulI64" + ;; ^:private compile-nat-div "/" + ;; ^:private compile-nat-rem "%" + ^:private compile-nat-eq "eqI64" + ;; ^:private compile-nat-lt "<" + + ^:private compile-int-add "addI64" + ^:private compile-int-sub "subI64" + ^:private compile-int-mul "mulI64" + ;; ^:private compile-int-div "/" + ;; ^:private compile-int-rem "%" + ^:private compile-int-eq "eqI64" + ;; ^:private compile-int-lt "<" + + ^:private compile-deg-add "addI64" + ^:private compile-deg-sub "subI64" + ;; ^:private compile-deg-mul "*" + ;; ^:private compile-deg-div "/" + ^:private compile-deg-rem "subI64" + ^:private compile-deg-eq "eqI64" + ;; ^:private compile-deg-lt "<" + ^:private compile-deg-scale "mulI64" + ) + (do-template [<name> <opcode>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -85,31 +119,6 @@ =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 "*" @@ -294,10 +303,10 @@ "+" (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-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) + ;; "<" (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) @@ -311,11 +320,11 @@ "+" (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-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) + ;; "<" (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) @@ -326,11 +335,11 @@ (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-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) + ;; "<" (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) diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index 3c9186a1e..194248f10 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -936,58 +936,155 @@ ;; (.visitEnd)))] ;; nil))) +(def ^:private i64-methods + {"makeI64" (str "(function makeI64(high,low) {" + "return { H: (high|0), L: (low|0)};" + "})") + "notI64" (str "(function notI64(i64) {" + "return LuxRT.makeI64(~i64.H,~i64.L);" + "})") + "negateI64" (str "(function negateI64(i64) {" + "return LuxRT.addI64(LuxRT.notI64(i64),LuxRT.makeI64(0,1));" + "})") + "eqI64" (str "(function eqI64(l,r) {" + "return (l.H === r.H) && (l.L === r.L);" + "})") + "addI64" (str "(function addI64(l,r) {" + "var l48 = l.H >>> 16;" + "var l32 = l.H & 0xFFFF;" + "var l16 = l.L >>> 16;" + "var l00 = l.L & 0xFFFF;" + + "var r48 = r.H >>> 16;" + "var r32 = r.H & 0xFFFF;" + "var r16 = r.L >>> 16;" + "var r00 = r.L & 0xFFFF;" + + "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" + "x00 += l00 + r00;" + "x16 += x00 >>> 16;" + "x00 &= 0xFFFF;" + "x16 += l16 + r16;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x32 += l32 + r32;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x48 += l48 + r48;" + "x48 &= 0xFFFF;" + + "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "})") + "subI64" (str "(function subI64(l,r) {" + "return LuxRT.addI64(l,LuxRT.negateI64(r));" + "})") + "mulI64" (str "(function mulI64(l,r) {" + "if (l.H < 0) {" + (str "if (r.H < 0) {" + ;; Both are negative + "return mulI64(LuxRT.negateI64(l),LuxRT.negateI64(r));" + "}" + "else {" + ;; Left is negative + "return LuxRT.negateI64(mulI64(LuxRT.negateI64(l),r));" + "}") + "}" + "else if (r.H < 0) {" + ;; Right is negative + "return LuxRT.negateI64(mulI64(l,LuxRT.negateI64(r)));" + "}" + ;; Both are positive + "else {" + "var l48 = l.H >>> 16;" + "var l32 = l.H & 0xFFFF;" + "var l16 = l.L >>> 16;" + "var l00 = l.L & 0xFFFF;" + + "var r48 = r.H >>> 16;" + "var r32 = r.H & 0xFFFF;" + "var r16 = r.L >>> 16;" + "var r00 = r.L & 0xFFFF;" + + "var x48 = 0, x32 = 0, x16 = 0, x00 = 0;" + "x00 += l00 * r00;" + "x16 += x00 >>> 16;" + "x00 &= 0xFFFF;" + "x16 += l16 * r00;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x16 += l00 * r16;" + "x32 += x16 >>> 16;" + "x16 &= 0xFFFF;" + "x32 += l32 * r00;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x32 += l16 * r16;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x32 += l00 * r32;" + "x48 += x32 >>> 16;" + "x32 &= 0xFFFF;" + "x48 += (l48 * r00) + (l32 * r16) + (l16 * r32) + (l00 * r48);" + "x48 &= 0xFFFF;" + + "return LuxRT.makeI64((x48 << 16) | x32, (x16 << 16) | x00);" + "}" + "})") + }) + (def ^:private adt-methods - {:product_getLeft (str "(function product_getLeft(product,index) {" - "var index_min_length = (index+1);" - "if(product.length > index_min_length) {" - ;; No need for recursion - "return product[index];" - "}" - "else {" - ;; Needs recursion - "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" - "}" - "})") - :product_getRight (str "(function product_getRight(product,index) {" + {"product_getLeft" (str "(function product_getLeft(product,index) {" "var index_min_length = (index+1);" - "if(product.length === index_min_length) {" - ;; Last element. + "if(product.length > index_min_length) {" + ;; No need for recursion "return product[index];" "}" - "else if(product.length < index_min_length) {" - ;; Needs recursion - "return product_getRight(product[product.length - 1], (index_min_length - product.length));" - "}" "else {" - ;; Must slice - "return product.slice(index);" + ;; Needs recursion + "return product_getLeft(product[product.length - 1], (index_min_length - product.length));" "}" "})") - :sum_get (str "(function sum_get(sum,wantedTag,wantsLast) {" - "if(sum[0] === wantedTag && sum[1] === wantsLast) {" - ;; Exact match. - "return sum[2];" - "}" - "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" - "if(sum[1]) {" - ;; Must recurse. - "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" - "}" - ;; No match. - "else { return null; }" - "}" - ;; No match. - "else { return null; }" - "})") + "product_getRight" (str "(function product_getRight(product,index) {" + "var index_min_length = (index+1);" + "if(product.length === index_min_length) {" + ;; Last element. + "return product[index];" + "}" + "else if(product.length < index_min_length) {" + ;; Needs recursion + "return product_getRight(product[product.length - 1], (index_min_length - product.length));" + "}" + "else {" + ;; Must slice + "return product.slice(index);" + "}" + "})") + "sum_get" (str "(function sum_get(sum,wantedTag,wantsLast) {" + "if(sum[0] === wantedTag && sum[1] === wantsLast) {" + ;; Exact match. + "return sum[2];" + "}" + "else if(sum[0] < wantedTag || sum[1] !== wantsLast) {" + "if(sum[1]) {" + ;; Must recurse. + "return sum_get(sum[2], (wantedTag - sum[0]), wantsLast);" + "}" + ;; No match. + "else { return null; }" + "}" + ;; No match. + "else { return null; }" + "})") }) (def LuxRT "LuxRT") (def compile-LuxRT (|do [_ (return nil) - :let [rt-object (str "{" (->> adt-methods + :let [rt-object (str "{" (->> (merge adt-methods + i64-methods) (map (fn [[key val]] - (str (name key) ":" val))) + (str key ":" val))) (interpose ",") (reduce str "")) "}")]] diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj index cebe60d9c..d37a061f8 100644 --- a/luxc/src/lux/type.clj +++ b/luxc/src/lux/type.clj @@ -254,7 +254,7 @@ (fn [state] ((|do [mappings* (&/map% (fn [binding] (|let [[?id ?type] binding] - (if (.equals ^Object id ?id) + (if (= id ?id) (return binding) (|case ?type (&/$None) @@ -263,7 +263,7 @@ (&/$Some ?type*) (|case ?type* (&/$VarT ?id*) - (if (.equals ^Object id ?id*) + (if (= id ?id*) (return (&/T [?id &/$None])) (return binding)) @@ -287,7 +287,7 @@ (defn clean* [?tid type] (|case type (&/$VarT ?id) - (if (.equals ^Object ?tid ?id) + (if (= ?tid ?id) (|do [? (bound? ?id)] (if ? (deref ?id) @@ -298,7 +298,7 @@ ==type (clean* ?tid =type)] (|case ==type (&/$VarT =id) - (if (.equals ^Object ?tid =id) + (if (= ?tid =id) (|do [_ (unset-var ?id)] (return type)) (|do [_ (reset-var ?id ==type)] @@ -503,13 +503,13 @@ (type= xoutput youtput)) [(&/$VarT xid) (&/$VarT yid)] - (.equals ^Object xid yid) + (= xid yid) [(&/$BoundT xidx) (&/$BoundT yidx)] (= xidx yidx) [(&/$ExT xid) (&/$ExT yid)] - (.equals ^Object xid yid) + (= xid yid) [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) @@ -652,7 +652,7 @@ (&/with-attempt (|case [expected actual] [(&/$VarT ?eid) (&/$VarT ?aid)] - (if (.equals ^Object ?eid ?aid) + (if (= ?eid ?aid) (return fixpoints) (|do [ebound (fn [state] (|case ((deref ?eid) state) @@ -834,7 +834,7 @@ (check* class-loader fixpoints* invariant?? eR aR)) [(&/$ExT e!id) (&/$ExT a!id)] - (if (.equals ^Object e!id a!id) + (if (= e!id a!id) (return fixpoints) (check-error "" expected actual)) |