aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-02-11 19:58:26 -0400
committerEduardo Julian2017-02-11 19:58:26 -0400
commit12dcb6e964e0c54f4001413bc62b8bcb526fa9c4 (patch)
treea48ddea9c03715eacf5d52427e62d3a383ced50e
parent66ceed37b71921e14cae8a091df7738d9e587c2d (diff)
- Now doing common array analysis/compilation.
- Now doing common io/log! analysis/compilation. - Now doing common char/to-text analysis/compilation. - Expanded compilation of procedures in JS. - Expanded LuxRT in JS. - Fixed some bugs.
-rw-r--r--luxc/src/lux/analyser.clj2
-rw-r--r--luxc/src/lux/analyser/proc/common.clj80
-rw-r--r--luxc/src/lux/analyser/proc/jvm.clj40
-rw-r--r--luxc/src/lux/compiler/js/lux.clj24
-rw-r--r--luxc/src/lux/compiler/js/proc/common.clj115
-rw-r--r--luxc/src/lux/compiler/js/rt.clj278
-rw-r--r--luxc/src/lux/compiler/jvm/host.clj89
-rw-r--r--luxc/src/lux/type.clj3
-rw-r--r--stdlib/source/lux.lux17
9 files changed, 436 insertions, 212 deletions
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj
index f5a200cad..e2aa64590 100644
--- a/luxc/src/lux/analyser.clj
+++ b/luxc/src/lux/analyser.clj
@@ -134,7 +134,7 @@
(&/$Nil))) parameters]
(&/with-analysis-meta cursor exo-type
(case ?category
- "jvm" (&&jvm/analyse-host analyse exo-type compilers ?category ?proc ?args)
+ "jvm" (&&jvm/analyse-host analyse exo-type compilers ?proc ?args)
;; "js"
;; common
(&&common/analyse-proc analyse exo-type ?category ?proc ?args))
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj
index f6d1eef8e..3bbc47e88 100644
--- a/luxc/src/lux/analyser/proc/common.clj
+++ b/luxc/src/lux/analyser/proc/common.clj
@@ -179,17 +179,78 @@
^: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-char-to-text &type/Char &type/Text ["char" "to-text"]
- ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"]
- ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"]
+ ^:private analyse-deg-to-real &type/Deg &type/Real ["deg" "to-real"]
+ ^:private analyse-real-to-deg &type/Real &type/Deg ["real" "to-deg"]
+
+ ^:private analyse-lux-log! &type/Text &/$UnitT ["io" "log!"]
)
+(defn ^:private analyse-array-new [analyse exo-type ?values]
+ (|do [:let [(&/$Cons length (&/$Nil)) ?values]
+ =length (&&/analyse-1 analyse &type/Nat length)
+ _ (&type/check exo-type (&/$UnivQ (&/|list) (&type/Array (&/$BoundT 1))))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "new"]) (&/|list =length) (&/|list)))))))
+
+(defn ^:private analyse-array-get [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
+ =array (&&/analyse-1 analyse (&type/Array $var) array)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ _ (&type/check exo-type (&/$AppT &type/Maybe $var))
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list)))))))))
+
+(defn ^:private analyse-array-put [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Cons idx (&/$Cons elem (&/$Nil)))) ?values]
+ :let [array-type (&type/Array $var)]
+ =array (&&/analyse-1 analyse array-type array)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ =elem (&&/analyse-1 analyse $var elem)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "put"]) (&/|list =array =idx =elem) (&/|list)))))))))
+
+(defn ^:private analyse-array-remove [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
+ :let [array-type (&type/Array $var)]
+ =array (&&/analyse-1 analyse array-type array)
+ =idx (&&/analyse-1 analyse &type/Nat idx)
+ _ (&type/check exo-type array-type)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "remove"]) (&/|list =array =idx) (&/|list)))))))))
+
+(defn ^:private analyse-array-size [analyse exo-type ?values]
+ (&type/with-var
+ (fn [$var]
+ (|do [:let [(&/$Cons array (&/$Nil)) ?values]
+ =array (&&/analyse-1 analyse (&type/Array $var) array)
+ _ (&type/check exo-type &type/Nat)
+ _cursor &/cursor]
+ (return (&/|list (&&/|meta exo-type _cursor
+ (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list)))))))))
+
(defn analyse-proc [analyse exo-type category proc ?values]
(case category
"lux"
(case proc
"==" (analyse-lux-== analyse exo-type ?values))
+ "io"
+ (case proc
+ "log!" (analyse-lux-log! analyse exo-type ?values))
+
"text"
(case proc
"=" (analyse-text-eq analyse exo-type ?values)
@@ -205,13 +266,13 @@
"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-array-size analyse exo-type ?values))
+ "array"
+ (case proc
+ "new" (analyse-array-new analyse exo-type ?values)
+ "get" (analyse-array-get analyse exo-type ?values)
+ "put" (analyse-array-put analyse exo-type ?values)
+ "remove" (analyse-array-remove analyse exo-type ?values)
+ "size" (analyse-array-size analyse exo-type ?values))
"nat"
(case proc
@@ -281,6 +342,7 @@
"char"
(case proc
+ "to-text" (analyse-char-to-text analyse exo-type ?values)
"to-nat" (analyse-char-to-nat analyse exo-type ?values)
)
diff --git a/luxc/src/lux/analyser/proc/jvm.clj b/luxc/src/lux/analyser/proc/jvm.clj
index 480cb341a..72b871686 100644
--- a/luxc/src/lux/analyser/proc/jvm.clj
+++ b/luxc/src/lux/analyser/proc/jvm.clj
@@ -881,46 +881,6 @@
(return (&/|list (&&/|meta output-type _cursor
(&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type)))))))
-(let [length-type &type/Nat
- idx-type &type/Nat]
- (defn ^:private analyse-array-new [analyse exo-type ?values]
- (|do [:let [(&/$Cons length (&/$Nil)) ?values]
- :let [gclass (&/$GenericClass "java.lang.Object" (&/|list))
- array-type (&/$UnivQ (&/|list) (&/$HostT &host-type/array-data-tag (&/|list (&/$BoundT 1))))]
- gtype-env &/get-type-env
- =length (&&/analyse-1 analyse length-type length)
- _ (&type/check exo-type array-type)
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env)))))))
-
- (defn ^:private analyse-array-get [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- [arr-class arr-params] (ensure-object (&&/expr-type* =array))
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _ (&type/check exo-type (&/$AppT &type/Maybe inner-arr-type))
- _cursor &/cursor]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["array" "get"]) (&/|list =array =idx) (&/|list)))))))
-
- (defn ^:private analyse-array-remove [analyse exo-type ?values]
- (|do [:let [(&/$Cons array (&/$Cons idx (&/$Nil))) ?values]
- =array (&&/analyse-1+ analyse array)
- :let [array-type (&&/expr-type* =array)]
- [arr-class arr-params] (ensure-object array-type)
- _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class))
- :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params]
- =idx (&&/analyse-1 analyse idx-type idx)
- _cursor &/cursor
- :let [=elem (&&/|meta inner-arr-type _cursor
- (&&/$proc (&/T ["jvm" "null"]) (&/|list) (&/|list)))]
- _ (&type/check exo-type array-type)]
- (return (&/|list (&&/|meta exo-type _cursor
- (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list))))))))
-
(defn ^:private analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods]
(|do [module &/get-module-name
_ (compile-interface interface-decl supers =anns =methods)
diff --git a/luxc/src/lux/compiler/js/lux.clj b/luxc/src/lux/compiler/js/lux.clj
index a7b1217f0..61f21bf55 100644
--- a/luxc/src/lux/compiler/js/lux.clj
+++ b/luxc/src/lux/compiler/js/lux.clj
@@ -284,15 +284,18 @@
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))
+ =env-vars (&/map% (fn [=captured]
+ (|case =captured
+ [_ (&o/$captured ?scope ?captured-id ?source)]
+ (return (captured-name ?captured-id))))
+ (&/|vals ?env))
+ =env-values (&/map% (fn [=captured]
+ (|case =captured
+ [_ (&o/$captured ?scope ?captured-id ?source)]
+ (compile ?source)))
+ (&/|vals ?env))
=body (compile ?body)]
- (return (str "(function() {"
- (->> =env (&/fold str ""))
+ (return (str "(function(" (->> =env-vars (&/|interpose ",") (&/fold str "")) ") {"
"return "
(str "(function " function-name "() {"
"\"use strict\";"
@@ -316,7 +319,7 @@
" };"
"}"
"})")
- ";})()"))))
+ ";})(" (->> =env-values (&/|interpose ",") (&/fold str "")) ")"))))
(defn compile-def [compile ?name ?body def-meta]
(|do [module-name &/get-module-name
@@ -345,8 +348,7 @@
_
false)
def-type (&a/expr-type* ?body)
- _ (&/|log! (str "def-js >>\n"
- (string/replace def-js "
+ _ (&/|log! (string/replace def-js "
_ (&&/run-js! def-js)
def-value (&&/run-js!+ var-name)
_ (&/without-repl-closure
diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj
index 7e052892b..385761dbe 100644
--- a/luxc/src/lux/compiler/js/proc/common.clj
+++ b/luxc/src/lux/compiler/js/proc/common.clj
@@ -89,26 +89,26 @@
^: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-div "divN64"
+ ^:private compile-nat-rem "remN64"
^:private compile-nat-eq "eqI64"
- ;; ^:private compile-nat-lt "<"
+ ^:private compile-nat-lt "ltN64"
^: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-div "divI64"
+ ^:private compile-int-rem "remI64"
^:private compile-int-eq "eqI64"
- ;; ^:private compile-int-lt "<"
+ ^:private compile-int-lt "ltI64"
^:private compile-deg-add "addI64"
^:private compile-deg-sub "subI64"
- ;; ^:private compile-deg-mul "*"
- ;; ^:private compile-deg-div "/"
+ ^:private compile-deg-mul "mulD64"
+ ^:private compile-deg-div "divD64"
^:private compile-deg-rem "subI64"
^:private compile-deg-eq "eqI64"
- ;; ^:private compile-deg-lt "<"
+ ^:private compile-deg-lt "ltD64"
^:private compile-deg-scale "mulI64"
)
@@ -128,6 +128,22 @@
^:private compile-real-lt "<"
)
+(do-template [<name> <method>]
+ (defn <name> [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str &&rt/LuxRT "." <method> "(" =x ")"))))
+
+ ^:private compile-int-encode "encodeI64"
+ ^:private compile-nat-encode "encodeN64"
+ ^:private compile-deg-encode "encodeD64"
+ )
+
+(defn ^:private compile-real-encode [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ =x (compile ?x)]
+ (return (str "(" =x ")" ".toString()"))))
+
;; (defn ^:private compile-nat-lt [compile ?values special-args]
;; (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
;; ^MethodVisitor *writer* &/get-writer
@@ -166,35 +182,6 @@
;; ^: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]
@@ -261,24 +248,37 @@
^:private compile-int-to-nat
)
-(defn compile-text-eq [compile ?values special-args]
+(defn ^:private 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]
+(defn ^:private compile-text-append [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values]
=x (compile ?x)
=y (compile ?y)]
(return (str =x ".concat(" =y ")"))))
+(defn ^:private compile-char-to-text [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]]
+ (compile ?x)))
+
+(defn ^:private compile-lux-log! [compile ?values special-args]
+ (|do [:let [(&/$Cons ?message (&/$Nil)) ?values]
+ =message (compile ?message)]
+ (return (str "LuxRT.log(" =message ")"))))
+
(defn compile-proc [compile proc-category proc-name ?values special-args]
(case proc-category
;; "lux"
;; (case proc-name
;; "==" (compile-lux-== compile ?values special-args))
+ "io"
+ (case proc-name
+ "log!" (compile-lux-log! compile ?values special-args))
+
"text"
(case proc-name
"=" (compile-text-eq compile ?values special-args)
@@ -303,11 +303,11 @@
"+" (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)
- ;; "encode" (compile-nat-encode 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)
@@ -320,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)
@@ -335,12 +335,12 @@
(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)
- ;; "encode" (compile-deg-encode 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)
@@ -357,17 +357,18 @@
"%" (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)
+ "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)
- ;; )
+ "char"
+ (case proc-name
+ "to-text" (compile-char-to-text compile ?values special-args)
+ ;; "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/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj
index 194248f10..ce5bf5d16 100644
--- a/luxc/src/lux/compiler/js/rt.clj
+++ b/luxc/src/lux/compiler/js/rt.clj
@@ -765,47 +765,6 @@
;; (.visitInsn Opcodes/ARETURN)
;; (.visitMaxs 0 0)
;; (.visitEnd)))
-;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#172
-;; _ (let [$too-big (new Label)]
-;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil)
-;; (.visitCode)
-;; (.visitLdcInsn "+")
-;; (.visitVarInsn Opcodes/LLOAD 0)
-;; (.visitLdcInsn (long 0))
-;; (.visitInsn Opcodes/LCMP)
-;; (.visitJumpInsn Opcodes/IFLT $too-big)
-;; ;; then
-;; (.visitVarInsn Opcodes/LLOAD 0)
-;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;")
-;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
-;; (.visitInsn Opcodes/ARETURN)
-;; ;; else
-;; (.visitLabel $too-big)
-;; ;; Set up parts of the number string...
-;; ;; First digits
-;; (.visitVarInsn Opcodes/LLOAD 0)
-;; (.visitLdcInsn (int 1))
-;; (.visitInsn Opcodes/LUSHR)
-;; (.visitLdcInsn (long 5))
-;; (.visitInsn Opcodes/LDIV) ;; quot
-;; ;; Last digit
-;; (.visitInsn Opcodes/DUP2)
-;; (.visitLdcInsn (long 10))
-;; (.visitInsn Opcodes/LMUL)
-;; (.visitVarInsn Opcodes/LLOAD 0)
-;; swap2
-;; (.visitInsn Opcodes/LSUB) ;; quot, rem
-;; ;; Conversion to string...
-;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; quot, rem*
-;; (.visitInsn Opcodes/DUP_X2);; rem*, quot, rem*
-;; (.visitInsn Opcodes/POP) ;; rem*, quot
-;; (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toString" "(J)Ljava/lang/String;") ;; rem*, quot*
-;; (.visitInsn Opcodes/SWAP) ;; quot*, rem*
-;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
-;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;")
-;; (.visitInsn Opcodes/ARETURN)
-;; (.visitMaxs 0 0)
-;; (.visitEnd)))
;; ;; http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215
;; _ (let [$simple-case (new Label)]
;; (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_toUnsignedBigInteger" "(J)Ljava/math/BigInteger;" nil nil)
@@ -936,10 +895,57 @@
;; (.visitEnd)))]
;; nil)))
+(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) {"
+ "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 ^:private i64-methods
{"makeI64" (str "(function makeI64(high,low) {"
"return { H: (high|0), L: (low|0)};"
"})")
+ "MIN_VALUE" "{ H: 0x80000000, L: 0}"
+ "ONE" "{ H: 0, L: 1}"
"notI64" (str "(function notI64(i64) {"
"return LuxRT.makeI64(~i64.H,~i64.L);"
"})")
@@ -1030,59 +1036,163 @@
"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) {"
- "var index_min_length = (index+1);"
- "if(product.length === index_min_length) {"
- ;; Last element.
- "return product[index];"
+ "divI64" (str "(function divI64(l,r) {"
+ (str "if((r.H === 0) && (r.L === 0)) {"
+ ;; Special case: R = 0
+ "throw Error('division by zero');"
+ "}"
+ "else if((l.H === 0) && (l.L === 0)) {"
+ ;; Special case: L = 0
+ "return l;"
+ "}")
+ (str "if(LuxRT.eqI64(l,LuxRT.MIN_VALUE)) {"
+ ;; Special case: L = MIN
+ (str "if(LuxRT.eqI64(r,LuxRT.ONE) || LuxRT.eqI64(r,LuxRT.negateI64(LuxRT.ONE))) {"
+ ;; Special case: L = MIN, R = 1|-1
+ "return LuxRT.MIN_VALUE;"
"}"
- "else if(product.length < index_min_length) {"
- ;; Needs recursion
- "return product_getRight(product[product.length - 1], (index_min_length - product.length));"
+ ;; Special case: L = R = MIN
+ "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {"
+ "return LuxRT.ONE;"
"}"
+ ;; Special case: L = MIN
"else {"
- ;; Must slice
- "return product.slice(index);"
+ "var halfL = LuxRT.shrI64(l,LuxRT.ONE);"
+ "var approx = LuxRT.shlI64(LuxRT.divI64(halfL,r),LuxRT.ONE);"
+ (str "if((approx.H === 0) && (approx.L === 0)) {"
+ (str "if(r.H < 0) {"
+ "return LuxRT.ONE;"
+ "}"
+ "else {"
+ "return LuxRT.negateI64(LuxRT.ONE);"
+ "}")
+ "}"
+ "else {"
+ "var rem = LuxRT.subI64(l,LuxRT.mulI64(r,approx));"
+ "return LuxRT.addI64(approx,LuxRT.divI64(rem,r));"
+ "}")
+ "}")
+ "}"
+ "else if(LuxRT.eqI64(r,LuxRT.MIN_VALUE)) {"
+ ;; Special case: R = MIN
+ "return LuxRT.makeI64(0,0);"
+ "}")
+ ;; Special case: negatives
+ (str "if(l.H < 0) {"
+ (str "if(r.H < 0) {"
+ ;; Both are negative
+ "return LuxRT.divI64(LuxRT.negateI64(l),LuxRT.negateI64(r));"
"}"
- "})")
- "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; }"
- "})")
+ "else {"
+ ;; Only L is negative
+ "return LuxRT.negateI64(LuxRT.divI64(LuxRT.negateI64(l),r));"
+ "}")
+ "}"
+ "else if(r.H < 0) {"
+ ;; R is negative
+ "return LuxRT.negateI64(LuxRT.divI64(l,LuxRT.negateI64(r)));"
+ "}")
+ ;; Common case
+ (str "var res = { H: 0, L: 0};"
+ "var rem = l;"
+ (str "while(LuxRT.ltI64(r,rem) || LuxRT.eqI64(r,rem)) {"
+ "var approx = Math.max(1, Math.floor(LuxRT.toNumberI64(rem) / LuxRT.toNumberI64(r)));"
+ "var log2 = Math.ceil(Math.log(approx) / Math.LN2);"
+ "var delta = (log2 <= 48) ? 1 : Math.pow(2, log2 - 48);"
+ "var approxRes = LuxRT.fromNumberI64(approx);"
+ "var approxRem = LuxRT.mulI64(approxRes,r);"
+ (str "while((approxRem.H < 0) || LuxRT.ltI64(rem,approxRem)) {"
+ "approx -= delta;"
+ "approxRes = LuxRT.fromNumberI64(approx);"
+ "approxRem = LuxRT.mulI64(approxRes,r);"
+ "}")
+ (str "if((approxRes.H === 0) && (approxRes.L === 0)) {"
+ "approxRes = LuxRT.ONE;"
+ "}")
+ "res = LuxRT.addI64(res,approxRes);"
+ "rem = LuxRT.subI64(rem,approxRem);"
+ "}")
+ "return res;")
+ "})")
+ "remI64" (str "(function remI64(l,r) {"
+ "return LuxRT.subI64(l,LuxRT.mulI64(LuxRT.divI64(l,r),r));"
+ "})")
+ "encodeI64" (str "(function encodeI64(input) {"
+ ;; If input = 0
+ (str "if((input.H === 0) && (input.L === 0)) {"
+ "return '0';"
+ "}")
+ ;; If input < 0
+ (str "if(input.H < 0) {"
+ (str "if(LuxRT.eqI64(input,LuxRT.MIN_VALUE)) {"
+ "var radix = LuxRT.makeI64(0,10);"
+ "var div = LuxRT.divI64(input,radix);"
+ "var rem = LuxRT.subI64(LuxRT.mulI64(div,radix),input);"
+ "return LuxRT.encodeI64(div).concat(rem.L+'');"
+ "}")
+ "}"
+ "else {"
+ "return '-'.concat(LuxRT.encodeI64(LuxRT.negateI64(input)));"
+ "}")
+ ;; If input > 0
+ (str "var chunker = LuxRT.makeI64(0,1000000);"
+ "var rem = input;"
+ "var result = '';"
+ "while (true) {"
+ (str "var remDiv = LuxRT.divI64(rem,chunker);"
+ "var chunk = LuxRT.subI64(rem,LuxRT.mulI64(remDiv,chunker));"
+ "var digits = (chunk.L >>> 0)+'';"
+ "rem = remDiv;"
+ (str "if((rem.H === 0) && (rem.L === 0)) {"
+ "return digits.concat(result);"
+ "}"
+ "else {"
+ (str "while (digits.length < 6) {"
+ "digits = '0' + digits;"
+ "}")
+ "result = '' + digits + result;"
+ "}"))
+ "}")
+ "})")
+ "ltI64" (str "(function ltI64(l,r) {"
+ "var ln = l.H < 0;"
+ "var rn = r.H < 0;"
+ "if(ln && !rn) { return true; }"
+ "if(!ln && rn) { return false; }"
+ "return (LuxRT.subI64(l,r).H < 0);"
+ "})")
+ })
+
+(def ^:private n64-methods
+ {"encodeN64" (str "(function encodeN64(input) {"
+ (str "if(input.H < 0) {"
+ ;; Too big
+ "var lastDigit = LuxRT.remI64(input, LuxRT.makeI64(0,10));"
+ "var minusLastDigit = LuxRT.divI64(input, LuxRT.makeI64(0,10));"
+ "return '+'.concat(LuxRT.encodeI64(minusLastDigit)).concat(LuxRT.encodeI64(lastDigit));"
+ "}"
+ "else {"
+ ;; Small enough
+ "return '+'.concat(LuxRT.encodeI64(input));"
+ "}")
+ "})")
+ })
+
+(def ^:private io-methods
+ {"log" (str "(function log(message) {"
+ "console.log(message);"
+ (str "return " &&/unit ";")
+ "})")
})
(def LuxRT "LuxRT")
(def compile-LuxRT
- (|do [_ (return nil)
+ (|do [_ (&&/run-js! "var console = { log: print };")
:let [rt-object (str "{" (->> (merge adt-methods
- i64-methods)
+ i64-methods
+ n64-methods
+ io-methods)
(map (fn [[key val]]
(str key ":" val)))
(interpose ",")
diff --git a/luxc/src/lux/compiler/jvm/host.clj b/luxc/src/lux/compiler/jvm/host.clj
index 9583c3106..867dd1ff0 100644
--- a/luxc/src/lux/compiler/jvm/host.clj
+++ b/luxc/src/lux/compiler/jvm/host.clj
@@ -2290,6 +2290,16 @@
(&&/wrap-boolean))]]
(return nil)))
+(defn ^:private compile-array-new [compile ?values special-args]
+ (|do [:let [(&/$Cons ?length (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?length)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY "java/lang/Object")]]
+ (return nil)))
+
(defn ^:private compile-array-get [compile ?values special-args]
(|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
;; (&/$Nil) special-args
@@ -2323,6 +2333,54 @@
(.visitLabel $end))]]
(return nil)))
+(defn ^:private compile-array-put [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ _ (compile ?elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return nil)))
+
+(defn ^:private compile-array-remove [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")
+ (.visitInsn Opcodes/DUP))]
+ _ (compile ?idx)
+ :let [_ (doto *writer*
+ &&/unwrap-long
+ (.visitInsn Opcodes/L2I))]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ACONST_NULL)
+ (.visitInsn Opcodes/AASTORE))]]
+ (return nil)))
+
+(defn ^:private compile-array-size [compile ?values special-args]
+ (|do [:let [(&/$Cons ?array (&/$Nil)) ?values
+ ;; (&/$Nil) special-args
+ ]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?array)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARRAYLENGTH)
+ (.visitInsn Opcodes/I2L)
+ &&/wrap-long)]]
+ (return nil)))
+
(do-template [<name> <op>]
(defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?input (&/$Cons ?mask (&/$Nil))) ?values]
@@ -2611,6 +2669,14 @@
^:private compile-char-to-nat &&/unwrap-char &&/wrap-long widen
))
+(defn ^:private compile-char-to-text [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "toString" "()Ljava/lang/String;"))]]
+ (return nil)))
+
(do-template [<name>]
(defn <name> [compile ?values special-args]
(|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
@@ -2645,12 +2711,28 @@
(.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]]
(return nil)))
+(defn compile-io-log! [compile ?values special-args]
+ (|do [:let [(&/$Cons ?x (&/$Nil)) ?values]
+ ^MethodVisitor *writer* &/get-writer
+ :let [_ (doto *writer*
+ (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))]
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String")
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/String;)V")
+ (.visitLdcInsn &/unit-tag))]]
+ (return nil)))
+
(defn compile-host [compile proc-category proc-name ?values special-args]
(case proc-category
"lux"
(case proc-name
"==" (compile-lux-== compile ?values special-args))
+ "io"
+ (case proc-name
+ "log!" (compile-io-log! compile ?values special-args))
+
"text"
(case proc-name
"=" (compile-text-eq compile ?values special-args)
@@ -2668,7 +2750,11 @@
"array"
(case proc-name
- "get" (compile-array-get compile ?values special-args))
+ "new" (compile-array-new compile ?values special-args)
+ "get" (compile-array-get compile ?values special-args)
+ "put" (compile-array-put compile ?values special-args)
+ "remove" (compile-array-remove compile ?values special-args)
+ "size" (compile-array-size compile ?values special-args))
"nat"
(case proc-name
@@ -2733,6 +2819,7 @@
"char"
(case proc-name
"to-nat" (compile-char-to-nat compile ?values special-args)
+ "to-text" (compile-char-to-text compile ?values special-args)
)
"jvm"
diff --git a/luxc/src/lux/type.clj b/luxc/src/lux/type.clj
index d37a061f8..d3805cabc 100644
--- a/luxc/src/lux/type.clj
+++ b/luxc/src/lux/type.clj
@@ -32,6 +32,9 @@
(def Text (&/$NamedT (&/T ["lux" "Text"]) (&/$HostT "java.lang.String" &/$Nil)))
(def Ident (&/$NamedT (&/T ["lux" "Ident"]) (&/$ProdT Text Text)))
+(defn Array [elem-type]
+ (&/$HostT "#Array" (&/|list elem-type)))
+
(def Bottom
(&/$NamedT (&/T ["lux" "Bottom"])
(&/$UnivQ empty-env
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 1c74cac80..06c0fd2fd 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -2099,7 +2099,7 @@
#"\f" "\\f"
#"\"" "\\\""
#"\\" "\\\\"
- _ (_lux_proc ["jvm" "invokevirtual:java.lang.Object:toString:"] [x]))]
+ _ (_lux_proc ["char" "to-text"] [x]))]
($_ Text/append "#\"" as-text "\"")))
(macro:' #export (do-template tokens)
@@ -2241,6 +2241,13 @@
(-> Bool Bool)
(if x false true))
+(def:''' #export (log! message)
+ (list [["lux" "doc"] (#TextA "Logs message to standard output.
+
+ Useful for debugging.")])
+ (-> Text Unit)
+ (_lux_proc ["io" "log!"] [message]))
+
(def:''' (find-macro' modules current-module module name)
#Nil
(-> ($' List (& Text Module))
@@ -2998,14 +3005,6 @@
(#;Some (#;Right []))
(list (' #hidden))))
-(def:''' #export (log! message)
- (list [["lux" "doc"] (#TextA "Logs message to standard output.
-
- Useful for debugging.")])
- (-> Text Unit)
- (_lux_proc ["jvm" "invokevirtual:java.io.PrintStream:println:java.lang.String"]
- [(_lux_proc ["jvm" "getstatic:java.lang.System:out"] []) message]))
-
(macro:' #export (def: tokens)
(list [["lux" "doc"] (#TextA "## Defines global constants/functions.
(def: (rejoin-pair pair)