From 0ddbb7e68d3416428067386225119532665aa72c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 16 Aug 2016 20:09:07 -0400 Subject: - Improved support for Nat. --- src/lux/analyser/host.clj | 57 +++++++++++++++++++++++++++++++---------------- src/lux/base.clj | 2 +- src/lux/compiler/case.clj | 10 +++++++++ src/lux/compiler/host.clj | 22 +++++++++++++++++- src/lux/type.clj | 2 +- src/lux/type/host.clj | 7 ++++-- 6 files changed, 76 insertions(+), 24 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 110bf253f..194205487 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -549,8 +549,8 @@ ^:private analyse-jvm-dgt "dgt" "java.lang.Double" "java.lang.Boolean" ) -(let [length-type &type/Int - idx-type &type/Int] +(let [length-type &type/Nat + idx-type &type/Nat] (do-template [ ] (let [elem-type (&/$HostT &/$Nil) array-type (&/$HostT &/$Nil)] @@ -599,8 +599,8 @@ ;; else false))) -(let [length-type &type/Int - idx-type &type/Int] +(let [length-type &type/Nat + idx-type &type/Nat] (defn ^:private analyse-jvm-anewarray [analyse exo-type ?values] (|do [:let [(&/$Cons [_ (&/$TextS _gclass)] (&/$Cons length (&/$Nil))) ?values] gclass (&reader/with-source "jvm-anewarray" _gclass @@ -645,7 +645,7 @@ =array (&&/analyse-1+ analyse array) [arr-class arr-params] (ensure-object (&&/expr-type* =array)) _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - _ (&type/check exo-type &type/Int) + _ (&type/check exo-type &type/Nat) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) @@ -885,8 +885,8 @@ (return (&/|list (&&/|meta output-type _cursor (&&/$proc (&/T ["jvm" "load-class"]) (&/|list) (&/|list _class-name output-type))))))) -(let [length-type &type/Int - idx-type &type/Int] +(let [length-type &type/Nat + idx-type &type/Nat] (defn ^:private analyse-array-new [analyse exo-type ?values] (|do [:let [(&/$Cons length (&/$Nil)) ?values] :let [gclass (&/$GenericClass "java.lang.Object" (&/|list)) @@ -1008,9 +1008,9 @@ (do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons input (&/$Cons mask (&/$Nil))) ?values] - =mask (&&/analyse-1 analyse &type/Int mask) - =input (&&/analyse-1 analyse &type/Int input) - _ (&type/check exo-type &type/Int) + =mask (&&/analyse-1 analyse &type/Nat mask) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["bit" ]) (&/|list =input =mask) (&/|list))))))) @@ -1022,25 +1022,25 @@ (defn ^:private analyse-bit-count [analyse exo-type ?values] (|do [:let [(&/$Cons input (&/$Nil)) ?values] - =input (&&/analyse-1 analyse &type/Int input) - _ (&type/check exo-type &type/Int) + =input (&&/analyse-1 analyse &type/Nat input) + _ (&type/check exo-type &type/Nat) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["bit" "count"]) (&/|list =input) (&/|list))))))) -(do-template [ ] +(do-template [ ] (defn [analyse exo-type ?values] (|do [:let [(&/$Cons input (&/$Cons shift (&/$Nil))) ?values] - =shift (&&/analyse-1 analyse &type/Int shift) - =input (&&/analyse-1 analyse &type/Int input) - _ (&type/check exo-type &type/Int) + =shift (&&/analyse-1 analyse &type/Nat shift) + =input (&&/analyse-1 analyse input) + _ (&type/check exo-type ) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["bit" ]) (&/|list =input =shift) (&/|list))))))) - ^:private analyse-bit-shift-left "shift-left" - ^:private analyse-bit-shift-right "shift-right" - ^:private analyse-bit-unsigned-shift-right "unsigned-shift-right" + ^: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 ) (defn ^:private analyse-lux-== [analyse exo-type ?values] @@ -1101,6 +1101,19 @@ ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] ) +(do-template [ ] + (defn [analyse exo-type ?values] + (|do [:let [(&/$Cons x (&/$Nil)) ?values] + =x (&&/analyse-1 analyse x) + _ (&type/check exo-type ) + _cursor &/cursor] + (return (&/|list (&&/|meta _cursor + (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) + + ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] + ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] + ) + (defn analyse-host [analyse exo-type compilers category proc ?values] (|let [[_ _ compile-class compile-interface] compilers] (case category @@ -1139,6 +1152,12 @@ "decode" (analyse-nat-decode analyse exo-type ?values) "min-value" (analyse-nat-min-value analyse exo-type ?values) "max-value" (analyse-nat-max-value analyse exo-type ?values) + "to-int" (analyse-nat-to-int analyse exo-type ?values) + ) + + "int" + (case proc + "to-nat" (analyse-int-to-nat analyse exo-type ?values) ) "jvm" diff --git a/src/lux/base.clj b/src/lux/base.clj index ba42f702d..b5bd4e732 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1047,7 +1047,7 @@ (pr-str ?value) [_ ($NatS ?value)] - (Long/toUnsignedString ?value) + (str "+" (Long/toUnsignedString ?value)) [_ ($IntS ?value)] (pr-str ?value) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 08624d171..4ca543b8e 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -72,6 +72,16 @@ (.visitLdcInsn _value) (.visitJumpInsn Opcodes/IF_ICMPNE $else)) + (&o/$NatPM _value) + (doto writer + (.visitInsn Opcodes/DUP) + (.visitMethodInsn Opcodes/INVOKESTATIC "lux/LuxRT" "pm_stack_peek" "([Ljava/lang/Object;)Ljava/lang/Object;") + (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") + (.visitLdcInsn (long _value)) + (.visitInsn Opcodes/LCMP) + (.visitJumpInsn Opcodes/IFNE $else)) + (&o/$IntPM _value) (doto writer (.visitInsn Opcodes/DUP) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index cdfc7dc7e..b6cd643d6 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1570,7 +1570,10 @@ (.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;"))]] + (.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] @@ -1597,6 +1600,17 @@ ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long ) +(do-template [] + (defn [compile ?values special-args] + (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] + ^MethodVisitor *writer* &/get-writer + _ (compile ?x)] + (return nil))) + + ^:private compile-nat-to-int + ^:private compile-int-to-nat + ) + (defn compile-host [compile proc-category proc-name ?values special-args] (case proc-category "lux" @@ -1630,6 +1644,12 @@ "decode" (compile-nat-decode compile ?values special-args) "max-value" (compile-nat-max-value compile ?values special-args) "min-value" (compile-nat-min-value compile ?values special-args) + "to-int" (compile-nat-to-int compile ?values special-args) + ) + + "int" + (case proc-name + "to-nat" (compile-int-to-nat compile ?values special-args) ) "jvm" diff --git a/src/lux/type.clj b/src/lux/type.clj index 7ca4145a6..8099eb914 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -92,7 +92,7 @@ TypePair (&/$SumT ;; BoundT - Int + Nat (&/$SumT ;; VarT Int diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index a3252ddb7..fe910c76e 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -269,11 +269,14 @@ (not= array-data-tag a!name)) (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) - (and (or (= nat-data-tag e!name) - (= "java.lang.Long" e!name)) + (and (= nat-data-tag e!name) (= nat-data-tag a!name)) (return fixpoints) + (or (= nat-data-tag e!name) + (= nat-data-tag a!name)) + (check-error "" (&/$HostT e!name e!params) (&/$HostT a!name a!params)) + :else (let [e!name (as-obj e!name) a!name (as-obj a!name)] -- cgit v1.2.3