diff options
-rw-r--r-- | src/lux/analyser/base.clj | 1 | ||||
-rw-r--r-- | src/lux/analyser/case.clj | 23 | ||||
-rw-r--r-- | src/lux/analyser/host.clj | 111 | ||||
-rw-r--r-- | src/lux/base.clj | 60 | ||||
-rw-r--r-- | src/lux/compiler.clj | 3 | ||||
-rw-r--r-- | src/lux/compiler/host.clj | 607 | ||||
-rw-r--r-- | src/lux/compiler/lux.clj | 1 | ||||
-rw-r--r-- | src/lux/compiler/type.clj | 4 | ||||
-rw-r--r-- | src/lux/lexer.clj | 5 | ||||
-rw-r--r-- | src/lux/optimizer.clj | 15 | ||||
-rw-r--r-- | src/lux/parser.clj | 3 | ||||
-rw-r--r-- | src/lux/type.clj | 30 | ||||
-rw-r--r-- | src/lux/type/host.clj | 11 |
13 files changed, 747 insertions, 127 deletions
diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 45d111249..302b5ba7c 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -14,6 +14,7 @@ ("bool" 1) ("nat" 1) ("int" 1) + ("frac" 1) ("real" 1) ("char" 1) ("text" 1) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index bccbd4a07..2fd787f28 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -20,6 +20,7 @@ ("BoolTotal" 2) ("NatTotal" 2) ("IntTotal" 2) + ("FracTotal" 2) ("RealTotal" 2) ("CharTotal" 2) ("TextTotal" 2) @@ -32,6 +33,7 @@ ("BoolTestAC" 1) ("NatTestAC" 1) ("IntTestAC" 1) + ("FracTestAC" 1) ("RealTestAC" 1) ("CharTestAC" 1) ("TextTestAC" 1) @@ -277,6 +279,11 @@ =kont kont] (return (&/T [($IntTestAC ?value) =kont]))) + (&/$FracS ?value) + (|do [_ (&type/check value-type &type/Frac) + =kont kont] + (return (&/T [($FracTestAC ?value) =kont]))) + (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] @@ -407,6 +414,9 @@ [($IntTotal total? ?values) ($NoTestAC)] (return ($IntTotal true ?values)) + [($FracTotal total? ?values) ($NoTestAC)] + (return ($FracTotal true ?values)) + [($RealTotal total? ?values) ($NoTestAC)] (return ($RealTotal true ?values)) @@ -434,6 +444,9 @@ [($IntTotal total? ?values) ($StoreTestAC ?idx)] (return ($IntTotal true ?values)) + [($FracTotal total? ?values) ($StoreTestAC ?idx)] + (return ($FracTotal true ?values)) + [($RealTotal total? ?values) ($StoreTestAC ?idx)] (return ($RealTotal true ?values)) @@ -467,6 +480,12 @@ [($IntTotal total? ?values) ($IntTestAC ?value)] (return ($IntTotal total? (&/$Cons ?value ?values))) + [($DefaultTotal total?) ($FracTestAC ?value)] + (return ($FracTotal total? (&/|list ?value))) + + [($FracTotal total? ?values) ($FracTestAC ?value)] + (return ($FracTotal total? (&/$Cons ?value ?values))) + [($DefaultTotal total?) ($RealTestAC ?value)] (return ($RealTotal total? (&/|list ?value))) @@ -554,6 +573,10 @@ (|do [_ (&type/check value-type &type/Int)] (return ?total)) + ($FracTotal ?total _) + (|do [_ (&type/check value-type &type/Frac)] + (return ?total)) + ($RealTotal ?total _) (|do [_ (&type/check value-type &type/Real)] (return ?total)) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 19971d95a..b84b31dff 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1045,8 +1045,8 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["bit" <op>]) (&/|list =input =shift) (&/|list))))))) - ^:private analyse-bit-shift-left "shift-left" &type/Nat - ^:private analyse-bit-shift-right "shift-right" &type/Int + ^:private analyse-bit-shift-left "shift-left" &type/Nat + ^:private analyse-bit-shift-right "shift-right" &type/Int ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" &type/Nat ) @@ -1069,32 +1069,55 @@ _ (&type/check exo-type <output-type>) _cursor &/cursor] (return (&/|list (&&/|meta <output-type> _cursor - (&&/$proc (&/T ["nat" <proc>]) (&/|list =x =y) (&/|list))))))) - - ^:private analyse-nat-add "add" &type/Nat &type/Nat - ^:private analyse-nat-sub "sub" &type/Nat &type/Nat - ^:private analyse-nat-mul "mul" &type/Nat &type/Nat - ^:private analyse-nat-div "div" &type/Nat &type/Nat - ^:private analyse-nat-rem "rem" &type/Nat &type/Nat - ^:private analyse-nat-eq "eq" &type/Nat &type/Bool - ^:private analyse-nat-lt "lt" &type/Nat &type/Bool + (&&/$proc (&/T <proc>) (&/|list =x =y) (&/|list))))))) + + ^:private analyse-nat-add ["nat" "+"] &type/Nat &type/Nat + ^:private analyse-nat-sub ["nat" "-"] &type/Nat &type/Nat + ^:private analyse-nat-mul ["nat" "*"] &type/Nat &type/Nat + ^:private analyse-nat-div ["nat" "/"] &type/Nat &type/Nat + ^:private analyse-nat-rem ["nat" "%"] &type/Nat &type/Nat + ^:private analyse-nat-eq ["nat" "="] &type/Nat &type/Bool + ^:private analyse-nat-lt ["nat" "<"] &type/Nat &type/Bool + + ^:private analyse-frac-add ["frac" "+"] &type/Frac &type/Frac + ^:private analyse-frac-sub ["frac" "-"] &type/Frac &type/Frac + ^:private analyse-frac-mul ["frac" "*"] &type/Frac &type/Frac + ^:private analyse-frac-div ["frac" "/"] &type/Frac &type/Frac + ^:private analyse-frac-rem ["frac" "%"] &type/Frac &type/Frac + ^:private analyse-frac-eq ["frac" "="] &type/Frac &type/Bool + ^:private analyse-frac-lt ["frac" "<"] &type/Frac &type/Bool ) -(defn ^:private analyse-nat-encode [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Nat x) - _ (&type/check exo-type &type/Text) +(defn ^:private analyse-frac-scale [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Cons y (&/$Nil))) ?values] + =x (&&/analyse-1 analyse &type/Frac x) + =y (&&/analyse-1 analyse &type/Nat y) + _ (&type/check exo-type &type/Frac) _cursor &/cursor] - (return (&/|list (&&/|meta &type/Text _cursor - (&&/$proc (&/T ["nat" "encode"]) (&/|list =x) (&/|list))))))) + (return (&/|list (&&/|meta &type/Frac _cursor + (&&/$proc (&/T ["frac" "scale"]) (&/|list =x =y) (&/|list))))))) + +(do-template [<encode> <encode-op> <decode> <decode-op> <type>] + (do (defn <encode> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse <type> x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T <encode-op>) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe <type>)] + (defn <decode> [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse &type/Text x) + _ (&type/check exo-type decode-type) + _cursor &/cursor] + (return (&/|list (&&/|meta decode-type _cursor + (&&/$proc (&/T <decode-op>) (&/|list =x) (&/|list))))))))) -(defn ^:private analyse-nat-decode [analyse exo-type ?values] - (|do [:let [(&/$Cons x (&/$Nil)) ?values] - =x (&&/analyse-1 analyse &type/Text x) - _ (&type/check exo-type (&/$AppT &type/Maybe &type/Nat)) - _cursor &/cursor] - (return (&/|list (&&/|meta (&/$AppT &type/Maybe &type/Nat) _cursor - (&&/$proc (&/T ["nat" "decode"]) (&/|list =x) (&/|list))))))) + ^:private analyse-nat-encode ["nat" "encode"] ^:private analyse-nat-decode ["nat" "decode"] &type/Nat + ^:private analyse-frac-encode ["frac" "encode"] ^:private analyse-frac-decode ["frac" "decode"] &type/Frac + ) (do-template [<name> <type> <op>] (defn <name> [analyse exo-type ?values] @@ -1104,8 +1127,11 @@ (return (&/|list (&&/|meta <type> _cursor (&&/$proc (&/T <op>) (&/|list) (&/|list))))))) - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] + ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + + ^:private analyse-frac-min-value &type/Frac ["frac" "min-value"] + ^:private analyse-frac-max-value &type/Frac ["frac" "max-value"] ) (do-template [<name> <from-type> <to-type> <op>] @@ -1117,10 +1143,13 @@ (return (&/|list (&&/|meta <to-type> _cursor (&&/$proc (&/T <op>) (&/|list =x) (&/|list))))))) - ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] - ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] - ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-nat-to-char &type/Nat &type/Char ["nat" "to-char"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ^:private analyse-char-to-nat &type/Char &type/Nat ["char" "to-nat"] + + ^:private analyse-frac-to-real &type/Frac &type/Real ["frac" "to-real"] + ^:private analyse-real-to-frac &type/Real &type/Frac ["real" "to-frac"] ) (defn analyse-host [analyse exo-type compilers category proc ?values] @@ -1165,11 +1194,33 @@ "to-char" (analyse-nat-to-char analyse exo-type ?values) ) + "frac" + (case proc + "+" (analyse-frac-add analyse exo-type ?values) + "-" (analyse-frac-sub analyse exo-type ?values) + "*" (analyse-frac-mul analyse exo-type ?values) + "/" (analyse-frac-div analyse exo-type ?values) + "%" (analyse-frac-rem analyse exo-type ?values) + "=" (analyse-frac-eq analyse exo-type ?values) + "<" (analyse-frac-lt analyse exo-type ?values) + "encode" (analyse-frac-encode analyse exo-type ?values) + "decode" (analyse-frac-decode analyse exo-type ?values) + "min-value" (analyse-frac-min-value analyse exo-type ?values) + "max-value" (analyse-frac-max-value analyse exo-type ?values) + "to-real" (analyse-frac-to-real analyse exo-type ?values) + "scale" (analyse-frac-scale analyse exo-type ?values) + ) + "int" (case proc "to-nat" (analyse-int-to-nat analyse exo-type ?values) ) + "real" + (case proc + "to-frac" (analyse-real-to-frac analyse exo-type ?values) + ) + "char" (case proc "to-nat" (analyse-char-to-nat analyse exo-type ?values) diff --git a/src/lux/base.clj b/src/lux/base.clj index 3c4438c63..b31fcf11f 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -3,7 +3,8 @@ ;; If a copy of the MPL was not distributed with this file, ;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.base - (:require (clojure [template :refer [do-template]]) + (:require (clojure [template :refer [do-template]] + [string :as string]) [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) @@ -72,6 +73,7 @@ ("BoolS" 1) ("NatS" 1) ("IntS" 1) + ("FracS" 1) ("RealS" 1) ("CharS" 1) ("TextS" 1) @@ -216,6 +218,7 @@ ("BoolM" 1) ("NatM" 1) ("IntM" 1) + ("FracM" 1) ("RealM" 1) ("CharM" 1) ("TextM" 1) @@ -1041,6 +1044,58 @@ (fn [state] (return* state (get$ $cursor state)))) +(let [remove-trailing-0s (fn [^String input] + (-> input + (.split "0*$") + (aget 0))) + make-text-start-0 (fn [input] + (loop [accum "" + range 10] + (if (< input range) + (recur (.concat accum "0") + (* 10 range)) + accum))) + count-bin-start-0 (fn [input] + (loop [counter 0 + idx 63] + (if (and (> idx -1) + (not (bit-test input idx))) + (recur (inc counter) + (dec idx)) + counter))) + read-frac-text (fn [^String input] + (let [output* (.split input "0*$")] + (if (= 0 (alength output*)) + (Long/parseUnsignedLong (aget output* 0)) + (Long/parseUnsignedLong input)))) + count-leading-0s (fn [^String input] + (let [parts (.split input "^0*")] + (if (= 2 (alength parts)) + (.length (aget parts 0)) + 0)))] + (defn encode-frac [input] + (if (= 0 input) + ".0" + (->> input + (Long/toUnsignedString) + remove-trailing-0s + (.concat (->> (count-bin-start-0 input) + (bit-shift-left 1) + (make-text-start-0)))))) + + (defn decode-frac [input] + (if-let [[_ frac-text] (re-find #"^\.(.+)$" input)] + (let [output* (-> frac-text + (string/replace #",_" "") + read-frac-text) + rows-to-move-forward (count-bin-start-0 output*) + scaling-factor (long (Math/pow 10.0 (double (count-leading-0s input))))] + (-> output* + (bit-shift-left rows-to-move-forward) + (/ scaling-factor))) + (assert false (str "Invalid Frac syntax: " input)))) + ) + (defn show-ast [ast] (|case ast [_ ($BoolS ?value)] @@ -1052,6 +1107,9 @@ [_ ($IntS ?value)] (pr-str ?value) + [_ ($FracS ?value)] + (encode-frac ?value) + [_ ($RealS ?value)] (pr-str ?value) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 294f2dc63..171a5c05e 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -58,6 +58,9 @@ (&o/$int ?value) (&&lux/compile-int ?value) + (&o/$frac ?value) + (&&lux/compile-frac ?value) + (&o/$real ?value) (&&lux/compile-real ?value) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index cdd17a1ee..c59a616d8 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -718,6 +718,417 @@ (.visitEnd)))] nil)) +(defn ^:private low-4b [=method] + (doto =method + ;; Assume there is a long at the top of the stack... + ;; Add mask corresponding to -1 (FFFF...), on the low 32 bits. + (.visitLdcInsn (int -1)) + (.visitInsn Opcodes/I2L) + ;; Then do a bitwise and. + (.visitInsn Opcodes/LAND) + )) + +(defn ^:private high-4b [=method] + (doto =method + ;; Assume there is a long at the top of the stack... + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + )) + +(defn ^:private swap2 [=method] + (doto =method + ;; X2, Y2 + (.visitInsn Opcodes/DUP2_X2) ;; Y2, X2, Y2 + (.visitInsn Opcodes/POP2) ;; Y2, X2 + )) + +(defn ^:private bit-set-64? [=method] + (doto =method + ;; L, I + (.visitLdcInsn (long 1)) ;; L, I, L + (.visitInsn Opcodes/DUP2_X1) ;; L, L, I, L + (.visitInsn Opcodes/POP2) ;; L, L, I + (.visitInsn Opcodes/LSHL) ;; L, L + (.visitInsn Opcodes/LAND) ;; L + (.visitLdcInsn (long 0)) ;; L, L + (.visitInsn Opcodes/LCMP) ;; I + )) + +(defn ^:private compile-LuxRT-frac-methods [^ClassWriter =class] + (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "mul_frac" "(JJ)J" nil nil) + ;; Based on: http://stackoverflow.com/a/31629280/6823464 + (.visitCode) + ;; Bottom part + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Middle part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) low-4b + (.visitInsn Opcodes/LMUL) + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + (.visitInsn Opcodes/LADD) + ;; Join middle and bottom + (.visitInsn Opcodes/LADD) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LUSHR) + ;; Top part + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LMUL) + ;; Join top with rest + (.visitInsn Opcodes/LADD) + ;; Return + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "div_frac" "(JJ)J" nil nil) + (.visitCode) + ;; Based on: http://stackoverflow.com/a/8510587/6823464 + (.visitVarInsn Opcodes/LLOAD 0) + (.visitVarInsn Opcodes/LLOAD 2) high-4b + (.visitInsn Opcodes/LDIV) + (.visitLdcInsn (int 32)) + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "frac-to-real" "(J)D" nil nil) + (.visitCode) + ;; Translate high bytes + (.visitVarInsn Opcodes/LLOAD 0) high-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Translate low bytes + (.visitVarInsn Opcodes/LLOAD 0) low-4b + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DDIV) + ;; Combine and return + (.visitInsn Opcodes/DADD) + (.visitInsn Opcodes/DRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "real-to-frac" "(D)J" nil nil) + (.visitCode) + ;; Drop any excess + (.visitVarInsn Opcodes/DLOAD 0) + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + ;; Shift upper half, but retain remaining decimals + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Make a copy, so the lower half can be extracted + (.visitInsn Opcodes/DUP2) + ;; Get that lower half + (.visitLdcInsn (double 1.0)) + (.visitInsn Opcodes/DREM) + (.visitLdcInsn (double (Math/pow 2 32))) + (.visitInsn Opcodes/DMUL) + ;; Turn it into a frac + (.visitInsn Opcodes/D2L) + ;; Turn the upper half into frac too + swap2 + (.visitInsn Opcodes/D2L) + ;; Combine both pieces + (.visitInsn Opcodes/LADD) + ;; FINISH + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd)) + _ (let [$start (new Label) + $body (new Label) + $end (new Label) + $zero (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_bin_start_0" "(J)I" nil nil) + (.visitCode) + ;; Initialize counter + (.visitLdcInsn (int 0)) ; I + (.visitVarInsn Opcodes/ISTORE 2) ; + ;; Initialize index var + (.visitLdcInsn (int 63)) ; I + ;; Begin loop + (.visitLabel $start) ; I + ;; Make sure we're still on the valid index range + (.visitInsn Opcodes/DUP) ; I, I + (.visitLdcInsn (int -1)) ; I, I, I + (.visitJumpInsn Opcodes/IF_ICMPGT $body) ; I + ;; If not, just return what we've got. + (.visitInsn Opcodes/POP) ; + (.visitVarInsn Opcodes/ILOAD 2) ; I + (.visitJumpInsn Opcodes/GOTO $end) + ;; If so, run the body + (.visitLabel $body) ;; I + (.visitInsn Opcodes/DUP) ;; I, I + (.visitVarInsn Opcodes/LLOAD 0) ;; I, I, L + (.visitInsn Opcodes/DUP2_X1) ;; I, L, I, L + (.visitInsn Opcodes/POP2) ;; I, L, I + bit-set-64? ;; I, I + (.visitJumpInsn Opcodes/IFEQ $zero) ;; I + ;; No more zeroes from now on... + (.visitInsn Opcodes/POP) ;; + (.visitVarInsn Opcodes/ILOAD 2) ;; I + (.visitJumpInsn Opcodes/GOTO $end) + ;; Found another zero... + (.visitLabel $zero) ;; I + ;; Increase counter + (.visitVarInsn Opcodes/ILOAD 2) ;; I, I + (.visitLdcInsn (int 1)) ;; I, I, I + (.visitInsn Opcodes/IADD) ;; I, I + (.visitVarInsn Opcodes/ISTORE 2) ;; I + ;; Increase index, then iterate again... + (.visitLdcInsn (int 1)) ;; I, I + (.visitInsn Opcodes/ISUB) ;; I + (.visitJumpInsn Opcodes/GOTO $start) + ;; Finally, return + (.visitLabel $end) ; I + (.visitInsn Opcodes/IRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$start (new Label) + $can-append (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_text_start_0" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + ;; Initialize accum + (.visitLdcInsn "") ;; S + (.visitVarInsn Opcodes/ASTORE 2) ;; + ;; Initialize comparator + (.visitLdcInsn (long 10)) ;; L + ;; Testing/accum loop + (.visitLabel $start) ;; L + (.visitInsn Opcodes/DUP2) ;; L, L + (.visitVarInsn Opcodes/LLOAD 0) ;; L, L, L + (.visitInsn Opcodes/LCMP) ;; L, I + (.visitJumpInsn Opcodes/IFLT $can-append) ;; L + ;; No more testing. + ;; Throw away the comparator and return accum. + (.visitInsn Opcodes/POP2) ;; + (.visitVarInsn Opcodes/ALOAD 2) ;; S + (.visitJumpInsn Opcodes/GOTO $end) + ;; Can keep accumulating + (.visitLabel $can-append) ;; L + ;; Add one more 0 to accum + (.visitVarInsn Opcodes/ALOAD 2) ;; L, S + (.visitLdcInsn "0") ;; L, S, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") ;; L, S + (.visitVarInsn Opcodes/ASTORE 2) ;; L + ;; Update comparator and re-iterate + (.visitLdcInsn (long 10)) ;; L, L + (.visitInsn Opcodes/LMUL) ;; L + (.visitJumpInsn Opcodes/GOTO $start) + (.visitLabel $end) ;; S + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$is-zero (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_frac" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFEQ $is-zero) + ;; IF =/= 0 + ;; Generate leading 0s + (.visitLdcInsn (long 1)) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") + (.visitInsn Opcodes/LSHL) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_text_start_0" "(J)Ljava/lang/String;") + ;; Convert to number text + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "toUnsignedString" "(J)Ljava/lang/String;") + ;; Remove unnecessary trailing zeroes + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + ;; Join leading 0s with number text + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; FINISH + (.visitJumpInsn Opcodes/GOTO $end) + ;; IF == 0 + (.visitLabel $is-zero) + (.visitLdcInsn ".0") + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$end (new Label) + ;; $then (new Label) + $else (new Label) + $from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_frac" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + ;; Check prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ".") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + ;; Remove prefix + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/DUP) + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "read_frac_text" "(Ljava/lang/String;)J") + (.visitLabel $to) + (.visitInsn Opcodes/DUP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_bin_start_0" "(J)I") + (.visitInsn Opcodes/LSHL) + (.visitInsn Opcodes/DUP2_X1) + (.visitInsn Opcodes/POP2) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "count_leading_zeroes" "(Ljava/lang/String;)J") + (.visitInsn Opcodes/L2D) + (.visitLdcInsn (double 10.0)) + swap2 + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Math" "pow" "(DD)D") + (.visitInsn Opcodes/D2L) + (.visitInsn Opcodes/LDIV) + ;; (.visitJumpInsn Opcodes/GOTO $then) + ;; (.visitLabel $then) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $handler) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + ;; Doesn't start with necessary prefix. + (.visitLabel $else) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitLabel $end) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [string-bcn (&host-generics/->bytecode-class-name "java.lang.String") + $valid (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "count_leading_zeroes" "(Ljava/lang/String;)J" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) ;; S + (.visitLdcInsn "^0*") ;; S, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "split" "(Ljava/lang/String;)[Ljava/lang/String;") ;; [S + (.visitInsn Opcodes/DUP) ;; [S, [S + (.visitInsn Opcodes/ARRAYLENGTH) ;; [S, I + (.visitLdcInsn (int 2)) ;; [S, I, I + (.visitJumpInsn Opcodes/IF_ICMPEQ $valid) ;; [S + ;; Invalid... + (.visitInsn Opcodes/POP) ;; + (.visitLdcInsn (long 0)) ;; J + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $valid) ;; [S + ;; Valid... + (.visitLdcInsn (int 1)) ;; [S, I + (.visitInsn Opcodes/AALOAD) ;; S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I + (.visitVarInsn Opcodes/ALOAD 0) ;; I, S + (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "()I") ;; I, I + (.visitInsn Opcodes/SWAP) ;; I, I + (.visitInsn Opcodes/ISUB) ;; I + (.visitInsn Opcodes/I2L) ;; J + (.visitLabel $end) ;; J + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (let [$only-zeroes (new Label) + $end (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "read_frac_text" "(Ljava/lang/String;)J" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "0*$") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL + (&host-generics/->bytecode-class-name "java.lang.String") + "split" "(Ljava/lang/String;)[Ljava/lang/String;") + (.visitInsn Opcodes/DUP) + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitJumpInsn Opcodes/IFEQ $only-zeroes) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $only-zeroes) + (.visitInsn Opcodes/POP) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitLabel $end) + (.visitInsn Opcodes/LRETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ] + nil)) + +(let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + (defn ^:private compile-LuxRT-nat-methods [=class] + (|let [_ (let [$end (new Label) + ;; $then (new Label) + $else (new Label) + $from (new Label) + $to (new Label) + $handler (new Label)] + (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn "+") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn (int 1)) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") + (.visitTryCatchBlock $from $to $handler "java/lang/Exception") + (.visitLabel $from) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") + (.visitLabel $to) + ;; (.visitJumpInsn Opcodes/GOTO $then) + ;; (.visitLabel $then) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $handler) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) + (.visitInsn Opcodes/POP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitJumpInsn Opcodes/GOTO $end) + (.visitLabel $else) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") + (.visitLabel $end) + (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "encode_nat" "(J)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/LLOAD 0) + (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ "toUnsignedString" "(J)Ljava/lang/String;") + (.visitLdcInsn "+") + (.visitInsn Opcodes/SWAP) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))] + nil))) + (defn ^:private compile-LuxRT-pm-methods [=class] (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) (.visitCode) @@ -809,51 +1220,20 @@ (.visitInsn Opcodes/ARETURN) (.visitMaxs 0 0) (.visitEnd)) - _ (let [$end (new Label) - ;; $then (new Label) - $else (new Label) - $from (new Label) - $to (new Label) - $handler (new Label)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn "+") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "startsWith" "(Ljava/lang/String;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn (int 1)) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(I)Ljava/lang/String;") - (.visitTryCatchBlock $from $to $handler "java/lang/Exception") - (.visitLabel $from) - (.visitLdcInsn ",|_") - (.visitLdcInsn "") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Long" "parseUnsignedLong" "(Ljava/lang/String;)J") - (.visitLabel $to) - ;; (.visitJumpInsn Opcodes/GOTO $then) - ;; (.visitLabel $then) - (&&/wrap-long) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_some" "(Ljava/lang/Object;)Ljava/lang/Object;") - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $handler) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Exception"])) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $else) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 0 (to-array [])) - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "make_none" "()Ljava/lang/Object;") - (.visitLabel $end) - (.visitFrame Opcodes/F_NEW 1 (to-array ["java/lang/String"]) 1 (to-array ["java/lang/Object"])) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) + _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitLdcInsn ",|_") + (.visitLdcInsn "") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd)) _ (doto =class (compile-LuxRT-pm-methods) - (compile-LuxRT-adt-methods))]] + (compile-LuxRT-adt-methods) + (compile-LuxRT-nat-methods) + (compile-LuxRT-frac-methods))]] (&&/save-class! (second (string/split &&/lux-utils-class #"/")) (.toByteArray (doto =class .visitEnd))))) @@ -1513,9 +1893,14 @@ (<wrap>))]] (return nil))) - ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long - ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-nat-mul Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long + + ^:private compile-frac-add Opcodes/LADD "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-sub Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-rem Opcodes/LSUB "java.lang.Long" "longValue" "()J" &&/wrap-long + ^:private compile-frac-scale Opcodes/LMUL "java.lang.Long" "longValue" "()J" &&/wrap-long ) (do-template [<name> <wrapper-class> <value-method> <value-method-sig> <wrap> <comp-method> <comp-sig>] @@ -1568,33 +1953,10 @@ ^:private compile-nat-eq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" ^:private compile-nat-lt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" - ) - -(defn ^:private compile-nat-encode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ "longValue" "()J"))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ "toUnsignedString" "(J)Ljava/lang/String;") - (.visitLdcInsn "+") - (.visitInsn Opcodes/SWAP) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;"))]] - (return nil))) -(defn ^:private compile-nat-decode [compile ?values special-args] - (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] - :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "decode_nat" "(Ljava/lang/String;)Ljava/lang/Object;"))]] - (return nil))) + ^:private compile-frac-eq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" + ^:private compile-frac-lt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" "compareUnsigned" "(JJ)I" + ) (do-template [<name> <instr> <wrapper>] (defn <name> [compile ?values special-args] @@ -1607,6 +1969,71 @@ ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + + ^:private compile-frac-min-value (.visitLdcInsn 0) &&/wrap-long + ^:private compile-frac-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-frac-encode "encode_frac" ^:private compile-frac-decode "decode_frac" + ) + +(do-template [<name> <method>] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Cons ?y (&/$Nil))) ?values] + :let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.Long")] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + &&/unwrap-long)] + _ (compile ?y) + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) + &&/unwrap-long)] + :let [_ (doto *writer* + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> "(JJ)J") + &&/wrap-long)]] + (return nil))) + + ^:private compile-frac-mul "mul_frac" + ^:private compile-frac-div "div_frac" + ) + +(do-template [<name> <class> <method> <sig> <unwrap> <wrap>] + (let [+wrapper-class+ (&host-generics/->bytecode-class-name <class>)] + (defn <name> [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + <unwrap> + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" <method> <sig>) + <wrap>)]] + (return nil)))) + + ^:private compile-frac-to-real "java.lang.Long" "frac-to-real" "(J)D" &&/unwrap-long &&/wrap-double + ^:private compile-real-to-frac "java.lang.Double" "real-to-frac" "(D)J" &&/unwrap-double &&/wrap-long ) (do-template [<name>] @@ -1644,13 +2071,13 @@ "nat" (case proc-name - "add" (compile-nat-add compile ?values special-args) - "sub" (compile-nat-sub compile ?values special-args) - "mul" (compile-nat-mul compile ?values special-args) - "div" (compile-nat-div compile ?values special-args) - "rem" (compile-nat-rem compile ?values special-args) - "eq" (compile-nat-eq compile ?values special-args) - "lt" (compile-nat-lt compile ?values special-args) + "+" (compile-nat-add compile ?values special-args) + "-" (compile-nat-sub compile ?values special-args) + "*" (compile-nat-mul compile ?values special-args) + "/" (compile-nat-div compile ?values special-args) + "%" (compile-nat-rem compile ?values special-args) + "=" (compile-nat-eq compile ?values special-args) + "<" (compile-nat-lt compile ?values special-args) "encode" (compile-nat-encode compile ?values special-args) "decode" (compile-nat-decode compile ?values special-args) "max-value" (compile-nat-max-value compile ?values special-args) @@ -1658,12 +2085,34 @@ "to-int" (compile-nat-to-int compile ?values special-args) "to-char" (compile-nat-to-char compile ?values special-args) ) + + "frac" + (case proc-name + "+" (compile-frac-add compile ?values special-args) + "-" (compile-frac-sub compile ?values special-args) + "*" (compile-frac-mul compile ?values special-args) + "/" (compile-frac-div compile ?values special-args) + "%" (compile-frac-rem compile ?values special-args) + "=" (compile-frac-eq compile ?values special-args) + "<" (compile-frac-lt compile ?values special-args) + "encode" (compile-frac-encode compile ?values special-args) + "decode" (compile-frac-decode compile ?values special-args) + "max-value" (compile-frac-max-value compile ?values special-args) + "min-value" (compile-frac-min-value compile ?values special-args) + "to-real" (compile-frac-to-real compile ?values special-args) + "scale" (compile-frac-scale compile ?values special-args) + ) "int" (case proc-name "to-nat" (compile-int-to-nat compile ?values special-args) ) + "real" + (case proc-name + "to-frac" (compile-real-to-frac compile ?values special-args) + ) + "char" (case proc-name "to-nat" (compile-char-to-nat compile ?values special-args) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ba031eda7..360adb521 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -47,6 +47,7 @@ compile-nat "java/lang/Long" "(J)V" long compile-int "java/lang/Long" "(J)V" long + compile-frac "java/lang/Long" "(J)V" long compile-real "java/lang/Double" "(D)V" double compile-char "java/lang/Character" "(C)V" char ) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index f51165ea3..c7dbdb557 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -32,6 +32,7 @@ ^:private bool$ &a/$bool "(-> Bool Analysis)" ^:private nat$ &a/$nat "(-> Nat Analysis)" ^:private int$ &a/$int "(-> Int Analysis)" + ^:private frac$ &a/$frac "(-> Nat Analysis)" ^:private real$ &a/$real "(-> Real Analysis)" ^:private char$ &a/$char "(-> Char Analysis)" ^:private text$ &a/$text "(-> Text Analysis)" @@ -116,6 +117,9 @@ (&/$IntM value) (variant$ #'&/$IntM (int$ value)) + (&/$FracM value) + (variant$ #'&/$FracM (frac$ value)) + (&/$RealM value) (variant$ #'&/$RealM (real$ value)) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index f52823bfc..f519aa563 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -17,6 +17,7 @@ ("Bool" 1) ("Nat" 1) ("Int" 1) + ("Frac" 1) ("Real" 1) ("Char" 1) ("Text" 1) @@ -167,6 +168,7 @@ lex-nat $Nat #"^\+(0|[1-9][0-9,_]*)" lex-int $Int #"^-?(0|[1-9][0-9,_]*)" + lex-frac $Frac #"^(\.[0-9,_]+)" lex-real $Real #"^-?(0\.[0-9,_]+|[1-9][0-9,_]*\.[0-9,_]+)(e-?[1-9][0-9,_]*)?" ) @@ -241,8 +243,9 @@ (&/|list lex-white-space lex-comment lex-bool - lex-real lex-nat + lex-real + lex-frac lex-int lex-char lex-text diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 56a73060c..83b44931d 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -13,6 +13,7 @@ ("bool" 1) ("nat" 1) ("int" 1) + ("frac" 1) ("real" 1) ("char" 1) ("text" 1) @@ -72,6 +73,8 @@ ("NatPM" 1) ;; Compare the CDN with an integer value. ("IntPM" 1) + ;; Compare the CDN with a fractional value. + ("FracPM" 1) ;; Compare the CDN with a real value. ("RealPM" 1) ;; Compare the CDN with a character value. @@ -123,6 +126,10 @@ (&/|list ($IntPM _value) $PopPM) + (&a-case/$FracTestAC _value) + (&/|list ($FracPM _value) + $PopPM) + (&a-case/$RealTestAC _value) (&/|list ($RealPM _value) $PopPM) @@ -227,6 +234,11 @@ ($IntPM _pre-value) ($AltPM pre post)) + [($FracPM _pre-value) ($FracPM _post-value)] + (if (= _pre-value _post-value) + ($FracPM _pre-value) + ($AltPM pre post)) + [($RealPM _pre-value) ($RealPM _post-value)] (if (= _pre-value _post-value) ($RealPM _pre-value) @@ -533,6 +545,9 @@ (&a/$int value) (&/T [meta ($int value)]) + + (&a/$frac value) + (&/T [meta ($frac value)]) (&a/$real value) (&/T [meta ($real value)]) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index d5b4a54cd..ceafcd92e 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -82,6 +82,9 @@ (&lexer/$Int ?value) (return (&/|list (&/T [meta (&/$IntS (Long/parseLong ?value))]))) + (&lexer/$Frac ?value) + (return (&/|list (&/T [meta (&/$FracS (&/decode-frac ?value))]))) + (&lexer/$Real ?value) (return (&/|list (&/T [meta (&/$RealS (Double/parseDouble ?value))]))) diff --git a/src/lux/type.clj b/src/lux/type.clj index a198fabba..64b189949 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -28,7 +28,8 @@ (def empty-env &/$Nil) (def Bool (&/$NamedT (&/T ["lux" "Bool"]) (&/$HostT "java.lang.Boolean" &/$Nil))) -(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT "#Nat" &/$Nil))) +(def Nat (&/$NamedT (&/T ["lux" "Nat"]) (&/$HostT &&host/nat-data-tag &/$Nil))) +(def Frac (&/$NamedT (&/T ["lux" "Frac"]) (&/$HostT &&host/frac-data-tag &/$Nil))) (def Int (&/$NamedT (&/T ["lux" "Int"]) (&/$HostT "java.lang.Long" &/$Nil))) (def Real (&/$NamedT (&/T ["lux" "Real"]) (&/$HostT "java.lang.Double" &/$Nil))) (def Char (&/$NamedT (&/T ["lux" "Char"]) (&/$HostT "java.lang.Character" &/$Nil))) @@ -127,22 +128,25 @@ ;; IntM Int (&/$SumT - ;; RealM - Real + ;; FracM + Frac (&/$SumT - ;; CharM - Char + ;; RealM + Real (&/$SumT - ;; TextM - Text + ;; CharM + Char (&/$SumT - ;; IdentM - Ident + ;; TextM + Text (&/$SumT - ;; ListM - (&/$AppT List DefMetaValue) - ;; DictM - (&/$AppT List (&/$ProdT Text DefMetaValue)))))))))) + ;; IdentM + Ident + (&/$SumT + ;; ListM + (&/$AppT List DefMetaValue) + ;; DictM + (&/$AppT List (&/$ProdT Text DefMetaValue))))))))))) ) &/$VoidT)))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 75825514e..7a244b446 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -17,6 +17,7 @@ (def array-data-tag "#Array") (def null-data-tag "#Null") (def nat-data-tag "#Nat") +(def frac-data-tag "#Frac") ;; [Utils] (defn ^:private trace-lineage* [^Class super-class ^Class sub-class] @@ -269,12 +270,16 @@ (not= array-data-tag a!name)) (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) - (and (= nat-data-tag e!name) - (= nat-data-tag a!name)) + (or (and (= nat-data-tag e!name) + (= nat-data-tag a!name)) + (and (= frac-data-tag e!name) + (= frac-data-tag a!name))) (return fixpoints) (or (= nat-data-tag e!name) - (= nat-data-tag a!name)) + (= nat-data-tag a!name) + (= frac-data-tag e!name) + (= frac-data-tag a!name)) (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) :else |