diff options
Diffstat (limited to 'luxc/src')
| -rw-r--r-- | luxc/src/lux/analyser.clj | 2 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/proc/common.clj | 80 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/proc/jvm.clj | 40 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/lux.clj | 24 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/proc/common.clj | 115 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/rt.clj | 278 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm/host.clj | 89 | ||||
| -rw-r--r-- | luxc/src/lux/type.clj | 3 |
8 files changed, 428 insertions, 203 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 |