aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/lux/analyser/base.clj1
-rw-r--r--src/lux/analyser/case.clj23
-rw-r--r--src/lux/analyser/host.clj111
-rw-r--r--src/lux/base.clj60
-rw-r--r--src/lux/compiler.clj3
-rw-r--r--src/lux/compiler/host.clj607
-rw-r--r--src/lux/compiler/lux.clj1
-rw-r--r--src/lux/compiler/type.clj4
-rw-r--r--src/lux/lexer.clj5
-rw-r--r--src/lux/optimizer.clj15
-rw-r--r--src/lux/parser.clj3
-rw-r--r--src/lux/type.clj30
-rw-r--r--src/lux/type/host.clj11
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 13:27:39 +0000