From a95fcce5ee2eaf7209a96f778e27e3353395bb85 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 30 Sep 2016 03:37:35 -0400 Subject: - Added (almost) all the operations for implementing fractions in the compiler. - Still missing lexing for fractions... --- src/lux/analyser/host.clj | 111 ++++++--- src/lux/base.clj | 1 + src/lux/compiler/host.clj | 611 ++++++++++++++++++++++++++++++++++++++++------ src/lux/type.clj | 3 +- src/lux/type/host.clj | 11 +- 5 files changed, 624 insertions(+), 113 deletions(-) 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" ]) (&/|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 ) _cursor &/cursor] (return (&/|list (&&/|meta _cursor - (&&/$proc (&/T ["nat" ]) (&/|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 ) (&/|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 [ ] + (do (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta &type/Text _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + (let [decode-type (&/$AppT &type/Maybe )] + (defn [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 ) (&/|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 [ ] (defn [analyse exo-type ?values] @@ -1104,8 +1127,11 @@ (return (&/|list (&&/|meta _cursor (&&/$proc (&/T ) (&/|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 [ ] @@ -1117,10 +1143,13 @@ (return (&/|list (&&/|meta _cursor (&&/$proc (&/T ) (&/|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..fbcf92413 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -72,6 +72,7 @@ ("BoolS" 1) ("NatS" 1) ("IntS" 1) + ("FracS" 1) ("RealS" 1) ("CharS" 1) ("TextS" 1) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index cdd17a1ee..481145d3e 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -718,6 +718,421 @@ (.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 + )) + +(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 0)) ; I + ;; ;; Begin loop + ;; (.visitLabel $start) ; I + ;; ;; Make sure we're still on the valid index range + ;; (.visitInsn Opcodes/DUP) ; I, I + ;; (.visitLdcInsn (int 64)) ; I, I, I + ;; (.visitJumpInsn Opcodes/IF_ICMPLT $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, L + ;; (.visitLdcInsn (long 0)) ;; I, L, L + ;; (.visitLdcInsn Opcodes/LCMP) ;; 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/IADD) ;; 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 "") + ;; (.visitVarInsn Opcodes/ASTORE 2) + ;; ;; Initialize comparator + ;; (.visitLdcInsn (long 10)) + ;; ;; Testing/accum loop + ;; (.visitLabel $start) + ;; (.visitInsn Opcodes/DUP2) + ;; (.visitVarInsn Opcodes/LLOAD 0) + ;; (.visitInsn Opcodes/LCMP) + ;; (.visitJumpInsn Opcodes/IFLT $can-append) + ;; ;; No more testing. + ;; ;; Throw away the comparator and return accum. + ;; (.visitInsn Opcodes/POP) + ;; (.visitVarInsn Opcodes/ALOAD 2) + ;; (.visitJumpInsn Opcodes/GOTO $end) + ;; ;; Can keep accumulating + ;; (.visitLabel $can-append) + ;; ;; Add one more 0 to accum + ;; (.visitVarInsn Opcodes/ALOAD 2) + ;; (.visitLdcInsn "0") + ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") + ;; (.visitVarInsn Opcodes/ASTORE 2) + ;; ;; Update comparator and re-iterate + ;; (.visitLdcInsn (long 10)) + ;; (.visitInsn Opcodes/LMUL) + ;; (.visitJumpInsn Opcodes/GOTO $start) + ;; (.visitLabel $end) + ;; (.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 + ;; (&host-generics/->bytecode-class-name "java.lang.Long") + ;; "toUnsignedString" "(J)Ljava/lang/String;") + ;; ;; Remove unnecessary trailing zeroes + ;; (.visitLdcInsn "0*$") + ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL + ;; (&host-generics/->bytecode-class-name "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" "(Ljava/lang/String;)I") ;; I + ;; (.visitVarInsn Opcodes/ALOAD 0) ;; I, S + ;; (.visitMethodInsn Opcodes/INVOKEVIRTUAL string-bcn "length" "(Ljava/lang/String;)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 +1224,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 +1897,14 @@ ())]] (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 [ ] @@ -1568,33 +1957,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 [ ] (defn [compile ?values special-args] @@ -1607,6 +1973,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 [ ] + (do (defn [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" "(J)Ljava/lang/String;"))]] + (return nil))) + + (let [+wrapper-class+ (&host-generics/->bytecode-class-name "java.lang.String")] + (defn [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" "(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 [ ] + (defn [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" "(JJ)J") + &&/wrap-long)]] + (return nil))) + + ^:private compile-frac-mul "mul_frac" + ^:private compile-frac-div "div_frac" + ) + +(do-template [ ] + (let [+wrapper-class+ (&host-generics/->bytecode-class-name )] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x) + :let [_ (doto *writer* + + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" ) + )]] + (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 [] @@ -1644,13 +2075,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 +2089,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/type.clj b/src/lux/type.clj index a198fabba..c56dfa75c 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))) 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 -- cgit v1.2.3