diff options
Diffstat (limited to '')
| -rw-r--r-- | luxc/src/lux/analyser/proc/common.clj | 140 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/proc/common.clj | 150 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/js/rt.clj | 36 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm/proc/common.clj | 206 |
4 files changed, 458 insertions, 74 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index bec0855e1..9ab01801f 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -28,25 +28,38 @@ (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list))))))) ^:private analyse-text-eq ["text" "="] &type/Text &type/Bool + ^:private analyse-text-lt ["text" "<"] &type/Text &type/Bool ^:private analyse-text-append ["text" "append"] &type/Text &type/Text ) -(do-template [<name> <proc-name>] +(do-template [<name> <proc-name> <output-type>] (defn <name> [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Cons start (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) =part (&&/analyse-1 analyse &type/Text part) - _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) + =start (&&/analyse-1 analyse &type/Nat start) + _ (&type/check exo-type <output-type>) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["text" <proc-name>]) - (&/|list =text =part) + (&/|list =text =part =start) (&/|list))))))) - ^:private analyse-text-index "index" - ^:private analyse-text-last-index "last-index" + ^:private analyse-text-index "index" (&/$AppT &type/Maybe &type/Nat) + ^:private analyse-text-last-index "last-index" (&/$AppT &type/Maybe &type/Nat) ) +(defn ^:private analyse-text-contains? [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Cons part (&/$Nil))) ?values] + =text (&&/analyse-1 analyse &type/Text text) + =part (&&/analyse-1 analyse &type/Text part) + _ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" "contains?"]) + (&/|list =text =part) + (&/|list))))))) + (defn ^:private analyse-text-clip [analyse exo-type ?values] (|do [:let [(&/$Cons text (&/$Cons from (&/$Cons to (&/$Nil)))) ?values] =text (&&/analyse-1 analyse &type/Text text) @@ -71,15 +84,20 @@ (&/|list =text =to-find =replace-with) (&/|list))))))) -(defn ^:private analyse-text-size [analyse exo-type ?values] - (|do [:let [(&/$Cons text (&/$Nil)) ?values] - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["text" "size"]) - (&/|list =text) - (&/|list))))))) +(do-template [<name> <proc>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons text (&/$Nil)) ?values] + =text (&&/analyse-1 analyse &type/Text text) + _ (&type/check exo-type &type/Nat) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["text" <proc>]) + (&/|list =text) + (&/|list))))))) + + ^:private analyse-text-size "size" + ^:private analyse-text-hash "hash" + ) (do-template [<name> <proc>] (defn <name> [analyse exo-type ?values] @@ -187,6 +205,9 @@ ^: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 + + ^:private analyse-char-eq ["char" "="] &type/Char &type/Bool + ^:private analyse-char-lt ["char" "<"] &type/Char &type/Bool ) (defn ^:private analyse-deg-scale [analyse exo-type ?values] @@ -328,6 +349,61 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["array" "size"]) (&/|list =array) (&/|list))))))))) +(do-template [<name> <proc>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Nil) ?values] + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" <proc>]) (&/|list) (&/|list))))))) + + ^:private analyse-math-e "e" + ^:private analyse-math-pi "pi" + ) + +(do-template [<name> <proc>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" <proc>]) (&/|list =input) (&/|list))))))) + + ^:private analyse-math-cos "cos" + ^:private analyse-math-sin "sin" + ^:private analyse-math-tan "tan" + ^:private analyse-math-acos "acos" + ^:private analyse-math-asin "asin" + ^:private analyse-math-atan "atan" + ^:private analyse-math-cosh "cosh" + ^:private analyse-math-sinh "sinh" + ^:private analyse-math-tanh "tanh" + ^:private analyse-math-exp "exp" + ^:private analyse-math-log "log" + ^:private analyse-math-root2 "root2" + ^:private analyse-math-root3 "root3" + ^:private analyse-math-degrees "degrees" + ^:private analyse-math-radians "radians" + ^:private analyse-math-ceil "ceil" + ^:private analyse-math-floor "floor" + ^:private analyse-math-round "round" + ) + +(do-template [<name> <proc>] + (defn <name> [analyse exo-type ?values] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + =input (&&/analyse-1 analyse &type/Real ?input) + =param (&&/analyse-1 analyse &type/Real ?param) + _ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&&/$proc (&/T ["math" <proc>]) (&/|list =input =param) (&/|list))))))) + + ^:private analyse-math-atan2 "atan2" + ^:private analyse-math-pow "pow" + ) + (defn analyse-proc [analyse exo-type category proc ?values] (case category "lux" @@ -342,16 +418,20 @@ "text" (case proc "=" (analyse-text-eq analyse exo-type ?values) + "<" (analyse-text-lt analyse exo-type ?values) "append" (analyse-text-append analyse exo-type ?values) "clip" (analyse-text-clip analyse exo-type ?values) "index" (analyse-text-index analyse exo-type ?values) "last-index" (analyse-text-last-index analyse exo-type ?values) "size" (analyse-text-size analyse exo-type ?values) + "hash" (analyse-text-hash analyse exo-type ?values) "replace-all" (analyse-text-replace-all analyse exo-type ?values) "trim" (analyse-text-trim analyse exo-type ?values) "char" (analyse-text-char analyse exo-type ?values) "upper-case" (analyse-text-upper-case analyse exo-type ?values) - "lower-case" (analyse-text-lower-case analyse exo-type ?values)) + "lower-case" (analyse-text-lower-case analyse exo-type ?values) + "contains?" (analyse-text-contains? analyse exo-type ?values) + ) "bit" (case proc @@ -445,9 +525,37 @@ "char" (case proc + "=" (analyse-char-eq analyse exo-type ?values) + "<" (analyse-char-lt analyse exo-type ?values) "to-text" (analyse-char-to-text analyse exo-type ?values) "to-nat" (analyse-char-to-nat analyse exo-type ?values) ) + + "math" + (case proc + "e" (analyse-math-e analyse exo-type ?values) + "pi" (analyse-math-pi analyse exo-type ?values) + "cos" (analyse-math-cos analyse exo-type ?values) + "sin" (analyse-math-sin analyse exo-type ?values) + "tan" (analyse-math-tan analyse exo-type ?values) + "acos" (analyse-math-acos analyse exo-type ?values) + "asin" (analyse-math-asin analyse exo-type ?values) + "atan" (analyse-math-atan analyse exo-type ?values) + "cosh" (analyse-math-cosh analyse exo-type ?values) + "sinh" (analyse-math-sinh analyse exo-type ?values) + "tanh" (analyse-math-tanh analyse exo-type ?values) + "exp" (analyse-math-exp analyse exo-type ?values) + "log" (analyse-math-log analyse exo-type ?values) + "root2" (analyse-math-root2 analyse exo-type ?values) + "root3" (analyse-math-root3 analyse exo-type ?values) + "degrees" (analyse-math-degrees analyse exo-type ?values) + "radians" (analyse-math-radians analyse exo-type ?values) + "ceil" (analyse-math-ceil analyse exo-type ?values) + "floor" (analyse-math-floor analyse exo-type ?values) + "round" (analyse-math-round analyse exo-type ?values) + "atan2" (analyse-math-atan2 analyse exo-type ?values) + "pow" (analyse-math-pow analyse exo-type ?values) + ) ;; else (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " [category proc])))) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index ee381add4..11fb9fd95 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -69,6 +69,43 @@ =right (compile ?right)] (return (str "(" =left " === " =right ")")))) +(defn ^:private compile-array-new [compile ?values special-args] + (|do [:let [(&/$Cons ?length (&/$Nil)) ?values] + =length (compile ?length)] + (return (str "new Array(" (str "LuxRT.toNumberI64(" =length ")") ")")))) + +(defn ^:private compile-array-get [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayGet(" =array "," =idx ")")))) + +(defn ^:private compile-array-put [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx) + =elem (compile ?elem)] + (return (str "LuxRT.arrayPut(" =array "," =idx "," =elem ")")))) + +(defn ^:private compile-array-remove [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Cons ?idx (&/$Nil))) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array) + =idx (compile ?idx)] + (return (str "LuxRT.arrayRemove(" =array "," =idx ")")))) + +(defn ^:private compile-array-size [compile ?values special-args] + (|do [:let [(&/$Cons ?array (&/$Nil)) ?values + ;; (&/$Nil) special-args + ] + =array (compile ?array)] + (return (str =array ".length")))) + (do-template [<name> <method>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -134,10 +171,14 @@ ^:private compile-deg-decode "decodeD64" ^:private compile-real-decode "decodeReal" - - ^:private compile-real-hash "hashReal" ) +(defn ^:private compile-real-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str &&rt/LuxRT ".textHash(''+" =x ")")) + )) + (do-template [<name> <compiler> <value>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Nil) ?values]] @@ -222,28 +263,6 @@ ;; ^: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]] @@ -273,11 +292,27 @@ =x (compile ?x)] (return (str "LuxRT.realToDeg(" =x ")")))) -(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 ")")))) +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x <op> =y ")")))) + + ^:private compile-text-eq "===" + ^:private compile-text-lt "<" + ) + +(do-template [<name> <op>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + =x (compile ?x) + =y (compile ?y)] + (return (str "(" =x ".C" " " <op> " " =y ".C" ")")))) + + ^:private compile-char-eq "===" + ^:private compile-char-lt "<" + ) (defn ^:private compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] @@ -287,15 +322,26 @@ (do-template [<name> <method>] (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] =text (compile ?text) - =part (compile ?part)] - (return (str "LuxRT" "." <method> "(" =text "," =part ")")))) + =part (compile ?part) + =start (compile ?start)] + (return (str "LuxRT" "." <method> "(" =text "," =part "," =start ")")))) ^:private compile-text-last-index "lastIndex" ^:private compile-text-index "index" ) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + =text (compile ?text) + =part (compile ?part)] + (return (str "(" (str (str "(" =text ")") + ".indexOf" + (str "(" =part ")")) + " !== " "-1" + ")")))) + (defn ^:private compile-text-clip [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?from (&/$Cons ?to (&/$Nil)))) ?values] =text (compile ?text) @@ -315,6 +361,11 @@ =text (compile ?text)] (return (str "LuxRT.fromNumberI64(" =text ".length" ")")))) +(defn ^:private compile-text-hash [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + =text (compile ?text)] + (return (str "LuxRT.textHash(" =text ")")))) + (defn ^:private compile-text-char [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?idx (&/$Nil))) ?values] =text (compile ?text) @@ -337,6 +388,20 @@ =x (compile ?x)] (return (str "(" =x ").C")))) +(defn ^:private compile-char-to-nat [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "LuxRT.fromNumberI64(" (str "(" =x ").C" ".charCodeAt(0)") ")")))) + +(defn ^:private compile-nat-to-char [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + =x (compile ?x)] + (return (str "{C:" + (str "String.fromCharCode(" + (str "LuxRT.toNumberI64(" =x ")") + ")") + "}")))) + (defn ^:private compile-lux-log [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] =message (compile ?message)] @@ -361,16 +426,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) ;; "bit" @@ -383,9 +451,13 @@ ;; "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)) + "array" + (case proc-name + "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 @@ -401,7 +473,7 @@ "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) + "to-char" (compile-nat-to-char compile ?values special-args) ) "int" @@ -461,8 +533,10 @@ "char" (case proc-name - "to-text" (compile-char-to-text compile ?values special-args) - ;; "to-nat" (compile-char-to-nat compile ?values special-args) + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) + "to-text" (compile-char-to-text compile ?values special-args) + "to-nat" (compile-char-to-nat compile ?values special-args) ) ;; else diff --git a/luxc/src/lux/compiler/js/rt.clj b/luxc/src/lux/compiler/js/rt.clj index eaac37a6a..cc00e2908 100644 --- a/luxc/src/lux/compiler/js/rt.clj +++ b/luxc/src/lux/compiler/js/rt.clj @@ -1233,8 +1233,8 @@ (str "[1,''," value "]")) (def ^:private text-methods - {"index" (str "(function index(text,part) {" - "var idx = text.indexOf(part);" + {"index" (str "(function index(text,part,start) {" + "var idx = text.indexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1242,8 +1242,8 @@ (str "return " (make-some "LuxRT.fromNumberI64(idx)") ";") "}")) "})") - "lastIndex" (str "(function lastIndex(text,part) {" - "var idx = text.lastIndexOf(part);" + "lastIndex" (str "(function lastIndex(text,part,start) {" + "var idx = text.lastIndexOf(part,LuxRT.toNumberI64(start));" (str (str "if(idx === -1) {" "return " const-none ";" "}") @@ -1275,6 +1275,33 @@ "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');" "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);" "})") + "textHash" (str "(function(input) {" + "var hash = 0;" + (str "for(var i = 0; i < input.length; i++) {" + "hash = (((hash << 5) - hash) + input.charCodeAt(i)) & 0xFFFFFFFF;" + "}") + "return LuxRT.fromNumberI64(hash);" + "})") + }) + +(def ^:private array-methods + {"arrayGet" (str "(function arrayGet(arr,idx) {" + "var temp = arr[LuxRT.toNumberI64(idx)];" + (str "if(temp !== undefined) {" + (str "return " (make-some "temp") ";") + "}" + "else {" + (str "return " const-none ";") + "}") + "})") + "arrayPut" (str "(function arrayPut(arr,idx,val) {" + "arr[LuxRT.toNumberI64(idx)] = val;" + "return arr;" + "})") + "arrayRemove" (str "(function arrayRemove(arr,idx) {" + "delete arr[LuxRT.toNumberI64(idx)];" + "return arr;" + "})") }) (def LuxRT "LuxRT") @@ -1285,6 +1312,7 @@ i64-methods n64-methods text-methods + array-methods io-methods) (map (fn [[key val]] (str key ":" val))) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 01048fd98..63e7b9e76 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -265,6 +265,31 @@ ^:private compile-real-lt Opcodes/DCMPG -1 &&/unwrap-double ) +(do-template [<name> <opcode> <unwrap>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap>)] + _ (compile ?y) + :let [_ (doto *writer* + <unwrap>) + $then (new Label) + $end (new Label) + _ (doto *writer* + (.visitJumpInsn <opcode> $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))) + + ^:private compile-char-eq Opcodes/IF_ICMPEQ &&/unwrap-char + ^:private compile-char-lt Opcodes/IF_ICMPLT &&/unwrap-char + ) + (defn ^:private compile-real-hash [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer @@ -496,7 +521,7 @@ ^:private compile-int-to-real &&/unwrap-long Opcodes/L2D &&/wrap-double ) -(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] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -506,6 +531,28 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-text-lt [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 [$then (new Label) + $end (new Label) + _ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)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))) + (defn compile-text-append [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] ^MethodVisitor *writer* &/get-writer @@ -539,7 +586,7 @@ (do-template [<name> <method>] (defn <name> [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Nil))) ?values] + (|do [:let [(&/$Cons ?text (&/$Cons ?part (&/$Cons ?start (&/$Nil)))) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?text) :let [_ (doto *writer* @@ -547,8 +594,12 @@ _ (compile ?part) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?start) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" <method> "(Ljava/lang/String;)I"))] + &&/unwrap-long + (.visitInsn Opcodes/L2I))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" <method> "(Ljava/lang/String;I)I"))] :let [$not-found (new Label) $end (new Label) _ (doto *writer* @@ -569,16 +620,21 @@ ^:private compile-text-last-index "lastIndexOf" ) -(defn ^:private compile-text-size [compile ?values special-args] - (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "length" "()I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) +(do-template [<name> <class> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL <class> <method> "()I") + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] + (return nil))) + + ^:private compile-text-size "java/lang/String" "length" + ^:private compile-text-hash "java/lang/Object" "hashCode" + ) (defn ^:private compile-text-replace-all [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Cons ?pattern (&/$Cons ?replacement (&/$Nil)))) ?values] @@ -596,6 +652,20 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replace" "(Ljava/lang/CharSequence;Ljava/lang/CharSequence;)Ljava/lang/String;"))]] (return nil))) +(defn ^:private compile-text-contains? [compile ?values special-args] + (|do [:let [(&/$Cons ?text (&/$Cons ?sub (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?text) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + _ (compile ?sub) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "contains" "(Ljava/lang/CharSequence;)Z") + &&/wrap-boolean)]] + (return nil))) + (do-template [<name> <method>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?text (&/$Nil)) ?values] @@ -624,7 +694,7 @@ (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "text_char" "(Ljava/lang/String;I)[Ljava/lang/Object;"))]] (return nil))) -(defn compile-io-log [compile ?values special-args] +(defn ^:private compile-io-log [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -636,7 +706,7 @@ (.visitLdcInsn &/unit-tag))]] (return nil))) -(defn compile-io-error [compile ?values special-args] +(defn ^:private compile-io-error [compile ?values special-args] (|do [:let [(&/$Cons ?message (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -649,6 +719,79 @@ (.visitInsn Opcodes/ATHROW))]] (return nil))) +(do-template [<name> <field>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Nil) ?values] + ^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Math" <field> "D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-e "E" + ^:private compile-math-pi "PI" + ) + +(do-template [<name> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" <method> "(D)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-cos "cos" + ^:private compile-math-sin "sin" + ^:private compile-math-tan "tan" + ^:private compile-math-acos "acos" + ^:private compile-math-asin "asin" + ^:private compile-math-atan "atan" + ^:private compile-math-cosh "cosh" + ^:private compile-math-sinh "sinh" + ^:private compile-math-tanh "tanh" + ^:private compile-math-exp "exp" + ^:private compile-math-log "log" + ^:private compile-math-root2 "sqrt" + ^:private compile-math-root3 "cbrt" + ^:private compile-math-degrees "toDegrees" + ^:private compile-math-radians "toRadians" + ^:private compile-math-ceil "ceil" + ^:private compile-math-floor "floor" + ) + +(do-template [<name> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Cons ?param (&/$Nil))) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double)] + _ (compile ?param) + :let [_ (doto *writer* + &&/unwrap-double)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" <method> "(DD)D") + &&/wrap-double)]] + (return nil))) + + ^:private compile-math-atan2 "atan2" + ^:private compile-math-pow "pow" + ) + +(defn ^:private compile-math-round [compile ?values special-args] + (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?input) + :let [_ (doto *writer* + &&/unwrap-double + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "round" "(D)J") + (.visitInsn Opcodes/L2D) + &&/wrap-double)]] + (return nil))) + (defn compile-proc [compile proc-category proc-name ?values special-args] (case proc-category "lux" @@ -663,16 +806,19 @@ "text" (case proc-name "=" (compile-text-eq compile ?values special-args) + "<" (compile-text-lt compile ?values special-args) "append" (compile-text-append compile ?values special-args) "clip" (compile-text-clip compile ?values special-args) "index" (compile-text-index compile ?values special-args) "last-index" (compile-text-last-index compile ?values special-args) "size" (compile-text-size compile ?values special-args) + "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) + "char" (compile-text-char compile ?values special-args) "upper-case" (compile-text-upper-case compile ?values special-args) "lower-case" (compile-text-lower-case compile ?values special-args) - "char" (compile-text-char compile ?values special-args) + "contains?" (compile-text-contains? compile ?values special-args) ) "bit" @@ -767,9 +913,37 @@ "char" (case proc-name + "=" (compile-char-eq compile ?values special-args) + "<" (compile-char-lt compile ?values special-args) "to-nat" (compile-char-to-nat compile ?values special-args) "to-text" (compile-char-to-text compile ?values special-args) ) + + "math" + (case proc-name + "e" (compile-math-e compile ?values special-args) + "pi" (compile-math-pi compile ?values special-args) + "cos" (compile-math-cos compile ?values special-args) + "sin" (compile-math-sin compile ?values special-args) + "tan" (compile-math-tan compile ?values special-args) + "acos" (compile-math-acos compile ?values special-args) + "asin" (compile-math-asin compile ?values special-args) + "atan" (compile-math-atan compile ?values special-args) + "cosh" (compile-math-cosh compile ?values special-args) + "sinh" (compile-math-sinh compile ?values special-args) + "tanh" (compile-math-tanh compile ?values special-args) + "exp" (compile-math-exp compile ?values special-args) + "log" (compile-math-log compile ?values special-args) + "root2" (compile-math-root2 compile ?values special-args) + "root3" (compile-math-root3 compile ?values special-args) + "degrees" (compile-math-degrees compile ?values special-args) + "radians" (compile-math-radians compile ?values special-args) + "ceil" (compile-math-ceil compile ?values special-args) + "floor" (compile-math-floor compile ?values special-args) + "round" (compile-math-round compile ?values special-args) + "atan2" (compile-math-atan2 compile ?values special-args) + "pow" (compile-math-pow compile ?values special-args) + ) ;; else (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [proc-category proc-name])))) |