aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser.clj5
-rw-r--r--luxc/src/lux/analyser/jvm.clj73
-rw-r--r--luxc/src/lux/analyser/proc.clj285
-rw-r--r--luxc/src/lux/base.clj113
-rw-r--r--luxc/src/lux/compiler/js.clj22
-rw-r--r--luxc/src/lux/compiler/js/base.clj3
-rw-r--r--luxc/src/lux/compiler/js/lux.clj169
-rw-r--r--luxc/src/lux/compiler/js/proc.clj364
-rw-r--r--luxc/src/lux/compiler/jvm/host.clj104
-rw-r--r--stdlib/source/lux.lux298
-rw-r--r--stdlib/source/lux/control/comonad.lux11
-rw-r--r--stdlib/source/lux/control/monad.lux13
-rw-r--r--stdlib/source/lux/data/coll/list.lux2
-rw-r--r--stdlib/source/lux/io.lux2
-rw-r--r--stdlib/source/lux/macro/ast.lux2
15 files changed, 1131 insertions, 335 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)
)
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index cd16ce35f..1c74cac80 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -323,11 +323,11 @@
## (type: Cursor
## {#module Text
-## #line Int
-## #column Int})
+## #line Nat
+## #column Nat})
(_lux_def Cursor
(#NamedT ["lux" "Cursor"]
- (#ProdT Text (#ProdT Int Int)))
+ (#ProdT Text (#ProdT Nat Nat)))
(#Cons [["lux" "tags"] (#ListA (#Cons (#TextA "module")
(#Cons (#TextA "line")
(#Cons (#TextA "column")
@@ -673,16 +673,10 @@
default-def-meta-exported))
## Base functions & macros
-## (def: _cursor
-## Cursor
-## ["" -1 -1])
(_lux_def _cursor
- (_lux_: Cursor ["" -1 -1])
+ (_lux_: Cursor ["" +0 +0])
#Nil)
-## (def: (_meta data)
-## (-> (AST' (Meta Cursor)) AST)
-## [["" -1 -1] data])
(_lux_def _meta
(_lux_: (#LambdaT (#AppT AST'
(#AppT Meta Cursor))
@@ -691,11 +685,6 @@
[_cursor data]))
#Nil)
-## (def: (return x)
-## (All [a]
-## (-> a Compiler
-## (Either Text [Compiler a])))
-## ...)
(_lux_def return
(_lux_: (#UnivQ #Nil
(#LambdaT (#BoundT +1)
@@ -708,11 +697,6 @@
(#Right state val))))
#Nil)
-## (def: (fail msg)
-## (All [a]
-## (-> Text Compiler
-## (Either Text [Compiler a])))
-## ...)
(_lux_def fail
(_lux_: (#UnivQ #Nil
(#LambdaT Text
@@ -1044,7 +1028,7 @@
(def:'' (Text/= x y)
#Nil
(#LambdaT Text (#LambdaT Text Bool))
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:equals:java.lang.Object"] [x y]))
+ (_lux_proc ["text" "="] [x y]))
(def:'' (get-rep key env)
#Nil
@@ -1157,7 +1141,7 @@
#Nil
(#UnivQ #Nil
(#LambdaT ($' List (#BoundT +1)) Int))
- (fold (lambda'' [_ acc] (_lux_proc ["jvm" "ladd"] [1 acc])) 0 list))
+ (fold (lambda'' [_ acc] (_lux_proc ["int" "+"] [1 acc])) 0 list))
(macro:' #export (All tokens)
(#Cons [["lux" "doc"] (#TextA "## Universal quantification.
@@ -1469,7 +1453,7 @@
(def:''' (wrap-meta content)
#Nil
(-> AST AST)
- (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1)))
+ (tuple$ (list (tuple$ (list (text$ "") (nat$ +0) (nat$ +0)))
content)))
(def:''' (untemplate-list tokens)
@@ -1685,7 +1669,7 @@
(def:''' (Text/append x y)
#Nil
(-> Text Text Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.String:concat:java.lang.String"] [x y]))
+ (_lux_proc ["text" "append"] [x y]))
(def:''' (Ident/encode ident)
#Nil
@@ -1931,12 +1915,12 @@
(macro:' #export (|> tokens)
(list [["lux" "doc"] (#TextA "## Piping macro.
- (|> elems (map ->Text) (interpose \" \") (fold Text/append \"\"))
+ (|> elems (map Int/encode) (interpose \" \") (fold Text/append \"\"))
## =>
(fold Text/append \"\"
(interpose \" \"
- (map ->Text elems)))")])
+ (map Int/encode elems)))")])
(_lux_case tokens
(#Cons [init apps])
(return (list (fold (_lux_: (-> AST AST AST)
@@ -1958,12 +1942,12 @@
(macro:' #export (<| tokens)
(list [["lux" "doc"] (#TextA "## Reverse piping macro.
- (<| (fold Text/append \"\") (interpose \" \") (map ->Text) elems)
+ (<| (fold Text/append \"\") (interpose \" \") (map Int/encode) elems)
## =>
(fold Text/append \"\"
(interpose \" \"
- (map ->Text elems)))")])
+ (map Int/encode elems)))")])
(_lux_case (reverse tokens)
(#Cons [init apps])
(return (list (fold (_lux_: (-> AST AST AST)
@@ -2077,12 +2061,46 @@
(def:''' (i= x y)
#Nil
(-> Int Int Bool)
- (_lux_proc ["jvm" "leq"] [x y]))
+ (_lux_proc ["int" "="] [x y]))
-(def:''' (->Text x)
+(def:''' (Bool/encode x)
#Nil
- (-> (host java.lang.Object) Text)
- (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))
+ (-> Bool Text)
+ (if x "true" "false"))
+
+(def:''' (Nat/encode x)
+ #Nil
+ (-> Nat Text)
+ (_lux_proc ["nat" "encode"] [x]))
+
+(def:''' (Int/encode x)
+ #Nil
+ (-> Int Text)
+ (_lux_proc ["int" "encode"] [x]))
+
+(def:''' (Deg/encode x)
+ #Nil
+ (-> Deg Text)
+ (_lux_proc ["deg" "encode"] [x]))
+
+(def:''' (Real/encode x)
+ #Nil
+ (-> Real Text)
+ (_lux_proc ["real" "encode"] [x]))
+
+(def:''' (Char/encode x)
+ #Nil
+ (-> Char Text)
+ (let' [as-text (_lux_case x
+ #"\t" "\\t"
+ #"\b" "\\b"
+ #"\n" "\\n"
+ #"\r" "\\r"
+ #"\f" "\\f"
+ #"\"" "\\\""
+ #"\\" "\\\\"
+ _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
+ ($_ Text/append "#\"" as-text "\"")))
(macro:' #export (do-template tokens)
(list [["lux" "doc"] (#TextA "## By specifying a pattern (with holes), and the input data to fill those holes, repeats the pattern as many times as necessary.
@@ -2105,7 +2123,7 @@
(|> data'
(join-map (. apply (make-env bindings')))
return)
- (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (->Text num-bindings)))))
+ (fail (Text/append "Irregular arguments vectors for do-template. Expected size " (Int/encode num-bindings)))))
_
(fail "Wrong syntax for do-template"))
@@ -2113,47 +2131,47 @@
_
(fail "Wrong syntax for do-template")))
-(do-template [<type> <category> <=-name> <=> <lt-name> <lte-name> <lt> <gt-name> <gte-name>
+(do-template [<type> <category> <=-name> <lt-name> <lte-name> <gt-name> <gte-name>
<eq-doc> <<-doc> <<=-doc> <>-doc> <>=-doc>]
[(def:''' #export (<=-name> test subject)
(list [["lux" "doc"] (#TextA <eq-doc>)])
(-> <type> <type> Bool)
- (_lux_proc [<category> <=>] [subject test]))
+ (_lux_proc [<category> "="] [subject test]))
(def:''' #export (<lt-name> test subject)
(list [["lux" "doc"] (#TextA <<-doc>)])
(-> <type> <type> Bool)
- (_lux_proc [<category> <lt>] [subject test]))
+ (_lux_proc [<category> "<"] [subject test]))
(def:''' #export (<lte-name> test subject)
(list [["lux" "doc"] (#TextA <<=-doc>)])
(-> <type> <type> Bool)
- (if (_lux_proc [<category> <lt>] [subject test])
+ (if (_lux_proc [<category> "<"] [subject test])
true
- (_lux_proc [<category> <=>] [subject test])))
+ (_lux_proc [<category> "="] [subject test])))
(def:''' #export (<gt-name> test subject)
(list [["lux" "doc"] (#TextA <>-doc>)])
(-> <type> <type> Bool)
- (_lux_proc [<category> <lt>] [test subject]))
+ (_lux_proc [<category> "<"] [test subject]))
(def:''' #export (<gte-name> test subject)
(list [["lux" "doc"] (#TextA <>=-doc>)])
(-> <type> <type> Bool)
- (if (_lux_proc [<category> <lt>] [test subject])
+ (if (_lux_proc [<category> "<"] [test subject])
true
- (_lux_proc [<category> <=>] [subject test])))]
+ (_lux_proc [<category> "="] [subject test])))]
- [ Nat "nat" n.= "=" n.< n.<= "<" n.> n.>=
+ [ Nat "nat" n.= n.< n.<= n.> n.>=
"Natural equality." "Natural less-than." "Natural less-than-equal." "Natural greater-than." "Natural greater-than-equal."]
- [ Int "jvm" i.= "leq" i.< i.<= "llt" i.> i.>=
+ [ Int "int" i.= i.< i.<= i.> i.>=
"Integer equality." "Integer less-than." "Integer less-than-equal." "Integer greater-than." "Integer greater-than-equal."]
- [Deg "deg" d.= "=" d.< d.<= "<" d.> d.>=
+ [ Deg "deg" d.= d.< d.<= d.> d.>=
"Degree equality." "Degree less-than." "Degree less-than-equal." "Degree greater-than." "Degree greater-than-equal."]
- [Real "jvm" r.= "deq" r.< r.<= "dlt" r.> r.>=
+ [Real "real" r.= r.< r.<= r.> r.>=
"Real equality." "Real less-than." "Real less-than-equal." "Real greater-than." "Real greater-than-equal."]
)
@@ -2163,29 +2181,29 @@
(-> <type> <type> <type>)
(_lux_proc <op> [subject param]))]
- [ Nat n.+ ["nat" "+"] "Nat(ural) addition."]
- [ Nat n.- ["nat" "-"] "Nat(ural) substraction."]
- [ Nat n.* ["nat" "*"] "Nat(ural) multiplication."]
- [ Nat n./ ["nat" "/"] "Nat(ural) division."]
- [ Nat n.% ["nat" "%"] "Nat(ural) remainder."]
+ [ Nat n.+ [ "nat" "+"] "Nat(ural) addition."]
+ [ Nat n.- [ "nat" "-"] "Nat(ural) substraction."]
+ [ Nat n.* [ "nat" "*"] "Nat(ural) multiplication."]
+ [ Nat n./ [ "nat" "/"] "Nat(ural) division."]
+ [ Nat n.% [ "nat" "%"] "Nat(ural) remainder."]
- [ Int i.+ ["jvm" "ladd"] "Int(eger) addition."]
- [ Int i.- ["jvm" "lsub"] "Int(eger) substraction."]
- [ Int i.* ["jvm" "lmul"] "Int(eger) multiplication."]
- [ Int i./ ["jvm" "ldiv"] "Int(eger) division."]
- [ Int i.% ["jvm" "lrem"] "Int(eger) remainder."]
-
- [Deg d.+ ["deg" "+"] "Deg(ree) addition."]
- [Deg d.- ["deg" "-"] "Deg(ree) substraction."]
- [Deg d.* ["deg" "*"] "Deg(ree) multiplication."]
- [Deg d./ ["deg" "/"] "Deg(ree) division."]
- [Deg d.% ["deg" "%"] "Deg(ree) remainder."]
+ [ Int i.+ [ "int" "+"] "Int(eger) addition."]
+ [ Int i.- [ "int" "-"] "Int(eger) substraction."]
+ [ Int i.* [ "int" "*"] "Int(eger) multiplication."]
+ [ Int i./ [ "int" "/"] "Int(eger) division."]
+ [ Int i.% [ "int" "%"] "Int(eger) remainder."]
+
+ [ Deg d.+ [ "deg" "+"] "Deg(ree) addition."]
+ [ Deg d.- [ "deg" "-"] "Deg(ree) substraction."]
+ [ Deg d.* [ "deg" "*"] "Deg(ree) multiplication."]
+ [ Deg d./ [ "deg" "/"] "Deg(ree) division."]
+ [ Deg d.% [ "deg" "%"] "Deg(ree) remainder."]
- [Real r.+ ["jvm" "dadd"] "Real addition."]
- [Real r.- ["jvm" "dsub"] "Real substraction."]
- [Real r.* ["jvm" "dmul"] "Real multiplication."]
- [Real r./ ["jvm" "ddiv"] "Real division."]
- [Real r.% ["jvm" "drem"] "Real remainder."]
+ [Real r.+ ["real" "+"] "Real addition."]
+ [Real r.- ["real" "-"] "Real substraction."]
+ [Real r.* ["real" "*"] "Real multiplication."]
+ [Real r./ ["real" "/"] "Real division."]
+ [Real r.% ["real" "%"] "Real remainder."]
)
(do-template [<name> <type> <test> <doc>]
@@ -2196,14 +2214,14 @@
left
right))]
- [n.min Nat n.< "Nat(ural) minimum."]
- [n.max Nat n.> "Nat(ural) maximum."]
+ [n.min Nat n.< "Nat(ural) minimum."]
+ [n.max Nat n.> "Nat(ural) maximum."]
- [i.min Int i.< "Int(eger) minimum."]
- [i.max Int i.> "Int(eger) maximum."]
+ [i.min Int i.< "Int(eger) minimum."]
+ [i.max Int i.> "Int(eger) maximum."]
- [d.min Deg d.< "Deg(ree) minimum."]
- [d.max Deg d.> "Deg(ree) maximum."]
+ [d.min Deg d.< "Deg(ree) minimum."]
+ [d.max Deg d.> "Deg(ree) maximum."]
[r.min Real r.< "Real minimum."]
[r.max Real r.> "Real minimum."]
@@ -2530,16 +2548,16 @@
(-> Text ($' Lux AST))
(_lux_case state
{#info info #source source #modules modules
- #scopes scopes #type-vars types #host host
+ #scopes scopes #type-vars types #host host
#seed seed #expected expected
#cursor cursor
#scope-type-vars scope-type-vars #catching catching}
(#Right {#info info #source source #modules modules
- #scopes scopes #type-vars types #host host
+ #scopes scopes #type-vars types #host host
#seed (n.+ +1 seed) #expected expected
#cursor cursor
#scope-type-vars scope-type-vars #catching catching}
- (symbol$ ["" ($_ Text/append "__gensym__" prefix (->Text seed))]))))
+ (symbol$ ["" ($_ Text/append "__gensym__" prefix (Nat/encode seed))]))))
(macro:' #export (Rec tokens)
(list [["lux" "doc"] (#TextA "## Parameter-less recursive types.
@@ -2622,36 +2640,26 @@
(let' [[left right] pair]
(list left right)))
-(def:''' (Nat->Text x)
- #Nil
- (-> Nat Text)
- (_lux_proc ["nat" "encode"] [x]))
-
-(def:''' (Deg->Text x)
- #Nil
- (-> Deg Text)
- (_lux_proc ["deg" "encode"] [x]))
-
(def:' (ast-to-text ast)
(-> AST Text)
(_lux_case ast
[_ (#BoolS value)]
- (->Text value)
+ (Bool/encode value)
[_ (#NatS value)]
- (Nat->Text value)
+ (Nat/encode value)
[_ (#IntS value)]
- (->Text value)
+ (Int/encode value)
[_ (#DegS value)]
- (Deg->Text value)
+ (Deg/encode value)
[_ (#RealS value)]
- (->Text value)
+ (Real/encode value)
[_ (#CharS value)]
- ($_ Text/append "#" "\"" (->Text value) "\"")
+ ($_ Text/append "#" "\"" (Char/encode value) "\"")
[_ (#TextS value)]
($_ Text/append "\"" value "\"")
@@ -4158,13 +4166,13 @@
($_ Text/append "(-> " (|> (flatten-lambda type) (map Type/show) (interpose " ") reverse (fold Text/append "")) ")")
(#BoundT id)
- (Nat->Text id)
+ (Nat/encode id)
(#VarT id)
- ($_ Text/append "⌈v:" (->Text id) "⌋")
+ ($_ Text/append "⌈v:" (Nat/encode id) "⌋")
(#ExT id)
- ($_ Text/append "⟨e:" (->Text id) "⟩")
+ ($_ Text/append "⟨e:" (Nat/encode id) "⟩")
(#UnivQ env body)
($_ Text/append "(All " (Type/show body) ")")
@@ -4354,12 +4362,12 @@
(macro: #export (|>. tokens)
{#;doc "## Similar to the piping macro, but rather than taking an initial object to work on, creates a function for taking it.
- (|> (map ->Text) (interpose \" \") (fold Text/append \"\"))
+ (|> (map Int/encode) (interpose \" \") (fold Text/append \"\"))
## =>
(lambda [<something>]
(fold Text/append \"\"
(interpose \" \"
- (map ->Text <something>))))"}
+ (map Int/encode <something>))))"}
(do Monad<Lux>
[g!arg (gensym "arg")]
(return (list (` (lambda [(~ g!arg)] (|> (~ g!arg) (~@ tokens))))))))
@@ -4379,7 +4387,7 @@
(default 20 #;None) => 20"}
(case tokens
(^ (list else maybe))
- (let [g!temp (: AST [["" -1 -1] (#;SymbolS ["" ""])])
+ (let [g!temp (: AST [_cursor (#;SymbolS ["" ""])])
code (` (case (~ maybe)
(#;Some (~ g!temp))
(~ g!temp)
@@ -4793,7 +4801,7 @@
)
(def: (find-baseline-column ast)
- (-> AST Int)
+ (-> AST Nat)
(case ast
(^template [<tag>]
[[_ _ column] (<tag> _)]
@@ -4810,12 +4818,12 @@
(^template [<tag>]
[[_ _ column] (<tag> parts)]
- (fold i.min column (map find-baseline-column parts)))
+ (fold n.min column (map find-baseline-column parts)))
([#FormS]
[#TupleS])
[[_ _ column] (#RecordS pairs)]
- (fold i.min column
+ (fold n.min column
(List/append (map (. find-baseline-column first) pairs)
(map (. find-baseline-column second) pairs)))
))
@@ -4833,19 +4841,6 @@
_
(#Doc-Example ast)))
-(def: (Char/encode x)
- (-> Char Text)
- (let [as-text (case x
- #"\t" "\\t"
- #"\b" "\\b"
- #"\n" "\\n"
- #"\r" "\\r"
- #"\f" "\\f"
- #"\"" "\\\""
- #"\\" "\\\\"
- _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
- ($_ Text/append "#\"" as-text "\"")))
-
(def: (Text/encode original)
(-> Text Text)
(let [escaped (|> original
@@ -4865,16 +4860,28 @@
(-> <type> <type>)
(<op> <one> value))]
- [i.inc i.+ 1 Int "Increment function."]
- [i.dec i.- 1 Int "Decrement function."]
- [n.inc n.+ +1 Nat "Increment function."]
- [n.dec n.- +1 Nat "Decrement function."]
+ [i.inc i.+ 1 Int "[Int] Increment function."]
+ [i.dec i.- 1 Int "[Int] Decrement function."]
+ [n.inc n.+ +1 Nat "[Nat] Increment function."]
+ [n.dec n.- +1 Nat "[Nat] Decrement function."]
)
-(def: tag->Text
+(def: Tag/encode
(-> Ident Text)
(. (Text/append "#") Ident/encode))
+(do-template [<name> <op> <from> <to>]
+ [(def: #export (<name> input)
+ (-> <from> <to>)
+ (_lux_proc <op> [input]))]
+
+ [int-to-nat ["int" "to-nat"] Int Nat]
+ [nat-to-int ["nat" "to-int"] Nat Int]
+
+ [real-to-deg ["real" "to-deg"] Real Deg]
+ [deg-to-real ["deg" "to-real"] Deg Real]
+ )
+
(def: (repeat n x)
(All [a] (-> Int a (List a)))
(if (i.> 0 n)
@@ -4882,17 +4889,18 @@
#;Nil))
(def: (cursor-padding baseline [_ old-line old-column] [_ new-line new-column])
- (-> Int Cursor Cursor Text)
- (if (i.= old-line new-line)
- (Text/join (repeat (i.- old-column new-column) " "))
- (let [extra-lines (Text/join (repeat (i.- old-line new-line) "\n"))
- space-padding (Text/join (repeat (i.- baseline new-column) " "))]
+ (-> Nat Cursor Cursor Text)
+ (if (n.= old-line new-line)
+ (Text/join (repeat (nat-to-int (n.- old-column new-column)) " "))
+ (let [extra-lines (Text/join (repeat (nat-to-int (n.- old-line new-line)) "\n"))
+ space-padding (Text/join (repeat (nat-to-int (n.- baseline new-column)) " "))]
(Text/append extra-lines space-padding))))
(def: (Text/size x)
- (-> Text Int)
- (_lux_proc ["jvm" "i2l"]
- [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))
+ (-> Text Nat)
+ (:! Nat
+ (_lux_proc ["jvm" "i2l"]
+ [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])])))
(def: (Text/trim x)
(-> Text Text)
@@ -4900,18 +4908,18 @@
(def: (update-cursor [file line column] ast-text)
(-> Cursor Text Cursor)
- [file line (i.+ column (Text/size ast-text))])
+ [file line (n.+ column (Text/size ast-text))])
(def: (delim-update-cursor [file line column])
(-> Cursor Cursor)
- [file line (i.inc column)])
+ [file line (n.inc column)])
(def: rejoin-all-pairs
(-> (List [AST AST]) (List AST))
(. List/join (map rejoin-pair)))
(def: (doc-example->Text prev-cursor baseline example)
- (-> Cursor Int AST [Cursor Text])
+ (-> Cursor Nat AST [Cursor Text])
(case example
(^template [<tag> <show>]
[new-cursor (<tag> value)]
@@ -4919,15 +4927,15 @@
[(update-cursor new-cursor as-text)
(Text/append (cursor-padding baseline prev-cursor new-cursor)
as-text)]))
- ([#BoolS ->Text]
- [#NatS Nat->Text]
- [#IntS ->Text]
- [#DegS Deg->Text]
- [#RealS ->Text]
+ ([#BoolS Bool/encode]
+ [#NatS Nat/encode]
+ [#IntS Int/encode]
+ [#DegS Deg/encode]
+ [#RealS Real/encode]
[#CharS Char/encode]
[#TextS Text/encode]
[#SymbolS Ident/encode]
- [#TagS tag->Text])
+ [#TagS Tag/encode])
(^template [<tag> <open> <close> <prep>]
[group-cursor (<tag> parts)]
@@ -4947,7 +4955,7 @@
))
(def: (with-baseline baseline [file line column])
- (-> Int Cursor Cursor)
+ (-> Nat Cursor Cursor)
[file line baseline])
(def: (doc-fragment->Text fragment)
@@ -5166,7 +5174,7 @@
(compare <text> (:: AST/encode show <expr>))
(compare true (:: Eq<AST> = <expr> <expr>))]
- [(bool true) "true" [["" -1 -1] (#;BoolS true)]]
+ [(bool true) "true" [_ (#;BoolS true)]]
[(bool false) "false" [_ (#;BoolS false)]]
[(int 123) "123" [_ (#;IntS 123)]]
[(real 123.0) "123.0" [_ (#;RealS 123.0)]]
@@ -5447,7 +5455,7 @@
(wrap (list (` (#ExT (~ (nat$ var-id))))))
#;None
- (fail (Text/append "Indexed-type doesn't exist: " (->Text idx)))))
+ (fail (Text/append "Indexed-type doesn't exist: " (Nat/encode idx)))))
_
(fail "Wrong syntax for $")))
@@ -5537,7 +5545,7 @@
(do Monad<Lux>
[cursor get-cursor]
(let [[module line column] cursor
- cursor-prefix ($_ hack_Text/append "[" module "," (->Text line) "," (->Text column) "] ")]
+ cursor-prefix ($_ hack_Text/append "[" module "," (Nat/encode line) "," (Nat/encode column) "] ")]
(wrap (list (` (hack_Text/append (~ (text$ cursor-prefix)) (~ message)))))))
_
@@ -5591,18 +5599,6 @@
_
(fail "Wrong syntax for @post")))
-(do-template [<name> <op> <from> <to>]
- [(def: #export (<name> input)
- (-> <from> <to>)
- (_lux_proc <op> [input]))]
-
- [int-to-nat ["int" "to-nat"] Int Nat]
- [nat-to-int ["nat" "to-int"] Nat Int]
-
- [real-to-deg ["real" "to-deg"] Real Deg]
- [deg-to-real ["deg" "to-real"] Deg Real]
- )
-
(macro: #export (type-of tokens)
{#;doc (doc "Generates the type corresponding to a given definition or variable."
(let [my-num (: Int 123)]
diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux
index f78ffea17..5ed443040 100644
--- a/stdlib/source/lux/control/comonad.lux
+++ b/stdlib/source/lux/control/comonad.lux
@@ -18,6 +18,8 @@
split))
## [Syntax]
+(def: _cursor Cursor ["" +0 +0])
+
(macro: #export (be tokens state)
{#;doc (doc "A co-monadic parallel to the \"do\" macro."
(let [square (lambda [n] (i.* n n))]
@@ -26,9 +28,8 @@
(square (head inputs)))))}
(case tokens
(#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
- (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])])
- g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
- g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])])
+ (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])])
+ g!split (: AST [_cursor (#;SymbolS ["" " split "])])
body' (fold (: (-> [AST AST] AST AST)
(lambda [binding body']
(let [[var value] binding]
@@ -42,8 +43,8 @@
body
(reverse (as-pairs bindings)))]
(#;Right [state (#;Cons (` (;_lux_case (~ comonad)
- (~ g!@)
- (;_lux_case (~ g!@)
+ (~' @)
+ (;_lux_case (~' @)
{#functor {#F;map (~ g!map)} #unwrap (~' unwrap) #split (~ g!split)}
(~ body'))))
#;Nil)]))
diff --git a/stdlib/source/lux/control/monad.lux b/stdlib/source/lux/control/monad.lux
index 5c540791a..a6d0d5988 100644
--- a/stdlib/source/lux/control/monad.lux
+++ b/stdlib/source/lux/control/monad.lux
@@ -49,6 +49,8 @@
join))
## [Syntax]
+(def: _cursor Cursor ["" +0 +0])
+
(macro: #export (do tokens state)
{#;doc (doc "Macro for easy concatenation of monadic operations."
(do Monad<Maybe>
@@ -57,10 +59,9 @@
(wrap (f3 z))))}
(case tokens
(#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil)))
- (let [g!@ (: AST [["" -1 -1] (#;SymbolS ["" "@"])])
- g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])])
- g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])])
- g!apply (: AST [["" -1 -1] (#;SymbolS ["" " apply "])])
+ (let [g!map (: AST [_cursor (#;SymbolS ["" " map "])])
+ g!join (: AST [_cursor (#;SymbolS ["" " join "])])
+ g!apply (: AST [_cursor (#;SymbolS ["" " apply "])])
body' (fold (: (-> [AST AST] AST AST)
(lambda [binding body']
(let [[var value] binding]
@@ -74,8 +75,8 @@
body
(reverse (as-pairs bindings)))]
(#;Right [state (#;Cons (` (;_lux_case (~ monad)
- (~ g!@)
- (;_lux_case (~ g!@)
+ (~' @)
+ (;_lux_case (~' @)
{#applicative {#A;functor {#F;map (~ g!map)}
#A;wrap (~' wrap)
#A;apply (~ g!apply)}
diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux
index 4d9d9c270..5f2ef3984 100644
--- a/stdlib/source/lux/data/coll/list.lux
+++ b/stdlib/source/lux/data/coll/list.lux
@@ -335,7 +335,7 @@
## [Syntax]
(def: (symbol$ name)
(-> Text AST)
- [["" -1 -1] (#;SymbolS "" name)])
+ [["" +0 +0] (#;SymbolS "" name)])
(macro: #export (zip tokens state)
{#;doc (doc "Create list zippers with the specified number of input lists."
diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux
index 93c01ee85..8a9e6bb9e 100644
--- a/stdlib/source/lux/io.lux
+++ b/stdlib/source/lux/io.lux
@@ -19,7 +19,7 @@
"Some value...")))}
(case tokens
(^ (list value))
- (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])]
+ (let [blank (: AST [["" +0 +0] (#;SymbolS ["" ""])])]
(#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))]))
_
diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux
index 49d68b5c3..6647307dd 100644
--- a/stdlib/source/lux/macro/ast.lux
+++ b/stdlib/source/lux/macro/ast.lux
@@ -27,7 +27,7 @@
## (Meta Cursor (AST' (Meta Cursor))))
## [Utils]
-(def: _cursor Cursor ["" -1 -1])
+(def: _cursor Cursor ["" +0 +0])
## [Functions]
(do-template [<name> <type> <tag>]