diff options
17 files changed, 716 insertions, 555 deletions
diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux index 27b1c8688..23d2fb6d5 100644 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ b/lux-jvm/source/luxc/lang/directive/jvm.lux @@ -492,7 +492,7 @@ (dictionary.new nat.hash)) (def: bytecode - (-> (/.Bytecode /.Label) Inst) + (-> (/.Bytecode /.Label) jvm.Inst) (|>> [..fresh] ..relabel-bytecode product.right @@ -500,15 +500,15 @@ row.to-list _.fuse)) -(type: Pseudo-Handler - (-> Text (List Synthesis) (Try (/.Bytecode /.Label)))) +(type: Handler + (generation.Handler jvm.Anchor (/.Bytecode /.Label) jvm.Definition)) -(def: (true-handler pseudo) - (-> Pseudo-Handler jvm.Handler) +(def: (true-handler extender pseudo) + (-> jvm.Extender Any jvm.Handler) (function (_ extension-name phase archive inputs) - (|> (pseudo extension-name inputs) - (:: try.monad map ..bytecode) - phase.lift))) + (do phase.monad + [bytecode ((extender pseudo) extension-name phase archive inputs)] + (wrap (..bytecode (:coerce (/.Bytecode /.Label) bytecode)))))) (def: (def::generation extender) (-> jvm.Extender @@ -518,10 +518,9 @@ (^ (list nameC valueC)) (do phase.monad [[_ _ name] (lux/.evaluate! archive Text nameC) - [_ _ pseudo-handlerV] (lux/.evaluate! archive ..Pseudo-Handler valueC) - _ (|> pseudo-handlerV - (:coerce ..Pseudo-Handler) - ..true-handler + [_ handlerV] (lux/.generator archive (:coerce Text name) ..Handler valueC) + _ (|> handlerV + (..true-handler extender) (extension.install extender (:coerce Text name)) directive.lift-generation) _ (directive.lift-generation diff --git a/lux-jvm/source/luxc/lang/host/jvm.lux b/lux-jvm/source/luxc/lang/host/jvm.lux index 841b6a2a9..9301ab4ae 100644 --- a/lux-jvm/source/luxc/lang/host/jvm.lux +++ b/lux-jvm/source/luxc/lang/host/jvm.lux @@ -70,7 +70,7 @@ (template [<name> <base>] [(type: #export <name> - (<base> ..Anchor Inst Definition))] + (<base> ..Anchor ..Inst ..Definition))] [State generation.State] [Operation generation.Operation] diff --git a/lux-jvm/source/luxc/lang/translation/jvm/case.lux b/lux-jvm/source/luxc/lang/translation/jvm/case.lux index 573e9764b..d77e747fd 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/case.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/case.lux @@ -260,7 +260,7 @@ (..right-projection lefts))] (|>> so-far next))) recordG - path)))) + (list.reverse path))))) (def: #export (case phase archive [valueS path]) (Generator [Synthesis Path]) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux index a657a7a38..1cad5569f 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux @@ -67,7 +67,7 @@ (def: #export leftI Inst - (|>> (_.int +0) + (|>> _.ICONST_0 _.NULL _.DUP2_X1 _.POP2 @@ -75,7 +75,7 @@ (def: #export rightI Inst - (|>> (_.int +1) + (|>> _.ICONST_1 (_.string "") _.DUP2_X1 _.POP2 @@ -85,7 +85,7 @@ (def: #export noneI Inst - (|>> (_.int +0) + (|>> _.ICONST_0 _.NULL (_.string synthesis.unit) variantI)) @@ -115,12 +115,12 @@ (def: adt-methods Def - (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap type.int) _.AASTORE) - store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) - store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (let [store-tagI (|>> _.DUP _.ICONST_0 (_.ILOAD 0) (_.wrap type.int) _.AASTORE) + store-flagI (|>> _.DUP _.ICONST_1 (_.ALOAD 1) _.AASTORE) + store-valueI (|>> _.DUP _.ICONST_2 (_.ALOAD 2) _.AASTORE)] (|>> ($d.method #$.Public $.staticM "variant_make" (type.method [(list $Tag $Flag $Value) //.$Variant (list)]) - (|>> (_.int +3) + (|>> _.ICONST_3 (_.ANEWARRAY $Value) store-tagI store-flagI @@ -146,14 +146,20 @@ (def: pm-methods Def - (let [tuple-sizeI (|>> (_.ALOAD 0) _.ARRAYLENGTH) - last-rightI (|>> tuple-sizeI (_.int +1) _.ISUB) + (let [tuple-sizeI (|>> (_.ALOAD 0) + _.ARRAYLENGTH) + last-rightI (|>> tuple-sizeI + _.ICONST_1 + _.ISUB) leftsI (_.ILOAD 1) left-indexI leftsI sub-leftsI (|>> leftsI last-rightI _.ISUB) - sub-tupleI (|>> (_.ALOAD 0) last-rightI _.AALOAD (_.CHECKCAST //.$Tuple)) + sub-tupleI (|>> (_.ALOAD 0) + last-rightI + _.AALOAD + (_.CHECKCAST //.$Tuple)) recurI (: (-> Label Inst) (function (_ @loop) (|>> sub-leftsI (_.ISTORE 1) @@ -166,14 +172,14 @@ (|>> (illegal-state-exception "Error while applying function.") _.ATHROW)) ($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)]) - (|>> (_.int +2) + (|>> _.ICONST_2 (_.ANEWARRAY $Value) _.DUP - (_.int +1) + _.ICONST_1 (_.ALOAD 0) _.AASTORE _.DUP - (_.int +0) + _.ICONST_0 (_.ALOAD 1) _.AASTORE _.ARETURN)) @@ -253,7 +259,7 @@ _.with-label (function (_ @not-tail)) _.with-label (function (_ @slice)) (let [right-indexI (|>> leftsI - (_.int +1) + _.ICONST_1 _.IADD) right-accessI (|>> (_.ALOAD 0) _.SWAP diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux index e2cf047e9..ccb8ba414 100644 --- a/lux-jvm/source/program.lux +++ b/lux-jvm/source/program.lux @@ -82,13 +82,14 @@ (host.array-write 0 _object-class) (host.array-write 1 _object-class))) -(def: _apply4-args +(def: _apply5-args (Array (java/lang/Class java/lang/Object)) - (|> (host.array (java/lang/Class java/lang/Object) 4) + (|> (host.array (java/lang/Class java/lang/Object) 5) (host.array-write 0 _object-class) (host.array-write 1 _object-class) (host.array-write 2 _object-class) - (host.array-write 3 _object-class))) + (host.array-write 3 _object-class) + (host.array-write 4 _object-class))) (def: #export (expander macro inputs lux) Expander @@ -127,7 +128,7 @@ (:coerce Handler) (function (@self name phase)) (:coerce Phase) - (function (@self parameters)) + (function (@self archive parameters)) (:coerce Operation) (function (@self state)) (:coerce Try) @@ -137,14 +138,15 @@ [method (|> handler (:coerce java/lang/Object) (java/lang/Object::getClass) - (java/lang/Class::getMethod "apply" _apply4-args))] + (java/lang/Class::getMethod "apply" _apply5-args))] (java/lang/reflect/Method::invoke (:coerce java/lang/Object handler) - (|> (host.array java/lang/Object 4) + (|> (host.array java/lang/Object 5) (host.array-write 0 (:coerce java/lang/Object name)) (host.array-write 1 (:coerce java/lang/Object phase)) - (host.array-write 2 (:coerce java/lang/Object parameters)) - (host.array-write 3 (:coerce java/lang/Object state))) + (host.array-write 2 (:coerce java/lang/Object archive)) + (host.array-write 3 (:coerce java/lang/Object parameters)) + (host.array-write 4 (:coerce java/lang/Object state))) method)))) (def: (target service) diff --git a/stdlib/source/lux/control/parser/analysis.lux b/stdlib/source/lux/control/parser/analysis.lux index 824e2a83c..eb1757862 100644 --- a/stdlib/source/lux/control/parser/analysis.lux +++ b/stdlib/source/lux/control/parser/analysis.lux @@ -20,7 +20,8 @@ ["." list ("#@." functor)]]] [tool [compiler - [reference (#+)] + [reference (#+) + [variable (#+)]] [arity (#+ Arity)] [language [lux diff --git a/stdlib/source/lux/data/collection/tree/zipper.lux b/stdlib/source/lux/data/collection/tree/zipper.lux index cf6020ffe..029c27390 100644 --- a/stdlib/source/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/lux/data/collection/tree/zipper.lux @@ -94,19 +94,17 @@ zipper (#.Some parent) - (update@ #node (`` (for {(~~ (static @.old)) - (: (-> (Tree ($ 0)) (Tree ($ 0))) + (`` (for {(~~ (static @.old)) + (update@ #node (: (-> (Tree ($ 0)) (Tree ($ 0))) (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) (#.Cons (get@ #node zipper) - (get@ #rights zipper)))))} - (:share [a] - {(Zipper a) - zipper} - {(-> (Tree a) (Tree a)) - (set@ #//.children (list@compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))))}))) - parent))) + (get@ #rights zipper))))) + parent)} + (set@ [#node #//.children] + (list@compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + parent))))) (def: #export (start zipper) (All [a] (-> (Zipper a) (Zipper a))) diff --git a/stdlib/source/lux/extension.lux b/stdlib/source/lux/extension.lux index 4b0b7e4d2..a4254807b 100644 --- a/stdlib/source/lux/extension.lux +++ b/stdlib/source/lux/extension.lux @@ -43,6 +43,7 @@ {#name Code #label Text #phase Text + #archive Text #inputs (List Input)}) (def: (declaration default) @@ -51,11 +52,12 @@ <c>.any <c>.local-identifier <c>.local-identifier + <c>.local-identifier (<>.some (..input default))))) (template [<any> <end> <and> <run> <extension> <name>] [(syntax: #export (<name> - {[name extension phase inputs] (..declaration (` <any>))} + {[name extension phase archive inputs] (..declaration (` <any>))} body) (let [g!parser (case (list@map product.right inputs) #.Nil @@ -64,10 +66,11 @@ parsers (` (.$_ <and> (~+ parsers)))) g!name (code.local-identifier extension) - g!phase (code.local-identifier phase)] + g!phase (code.local-identifier phase) + g!archive (code.local-identifier archive)] (with-gensyms [g!handler g!inputs g!error] (wrap (list (` (<extension> (~ name) - (.function ((~ g!handler) (~ g!name) (~ g!phase) (~ g!inputs)) + (.function ((~ g!handler) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs)) (.case ((~! <run>) (~ g!parser) (~ g!inputs)) (#.Right [(~+ (list@map (|>> product.left code.local-identifier) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index ee51cd684..091d8e4a4 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -66,8 +66,8 @@ eval (///analysis/evaluation.evaluator expander synthesis-state generation-state generate) analysis-state [(analysisE.bundle eval host-analysis) (///analysis.state (///analysis.info ///version.version target))]] - [(dictionary.merge (luxD.bundle expander host-analysis program extender) - host-directive-bundle) + [(dictionary.merge host-directive-bundle + (luxD.bundle expander host-analysis program extender)) {#///directive.analysis {#///directive.state analysis-state #///directive.phase (analysisP.phase expander)} #///directive.synthesis {#///directive.state synthesis-state diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index 91d6a6447..77b9e0b8a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -213,12 +213,12 @@ (///bundle.install "and" (//lux.binary <type> <type> <type>)) (///bundle.install "or" (//lux.binary <type> <type> <type>)) (///bundle.install "xor" (//lux.binary <type> <type> <type>)) - (///bundle.install "shl" (//lux.binary <type> Integer <type>)) - (///bundle.install "shr" (//lux.binary <type> Integer <type>)) - (///bundle.install "ushr" (//lux.binary <type> Integer <type>)) + (///bundle.install "shl" (//lux.binary <type> ..int <type>)) + (///bundle.install "shr" (//lux.binary <type> ..int <type>)) + (///bundle.install "ushr" (//lux.binary <type> ..int <type>)) )))] - [bundle::int reflection.int ..long] + [bundle::int reflection.int ..int] [bundle::long reflection.long ..long] ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index b9ae14372..91de84cd1 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -159,7 +159,7 @@ _ (/////generation.save! false [(%.nat module-id) (%.nat id)] directive)] (wrap [codeG value]))))) - (def: (<full> archive extension codeT codeC) + (def: #export (<full> archive extension codeT codeC) (All [anchor expression directive] (-> Archive Text Type Code (Operation anchor expression directive [expression Any]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux index 0f110b906..889ac0265 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux @@ -251,7 +251,7 @@ (..right-projection lefts))] (_.compose so-far next))) recordG - path)))) + (list.reverse path))))) (def: #export (case phase archive [valueS path]) (Generator [Synthesis Path]) diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux index 6b382f6de..469ff4308 100644 --- a/stdlib/source/test/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux @@ -141,7 +141,10 @@ [_ (#.Some limit)] (and (n.> 0 raw) - (n.= raw (refinement.un-refine limit)))))) + (n.= raw (refinement.un-refine limit))) + + _ + false))) (do {@ random.monad} [limit (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) #let [barrier (/.barrier (maybe.assume (/.limit limit))) diff --git a/stdlib/source/test/lux/control/parser/analysis.lux b/stdlib/source/test/lux/control/parser/analysis.lux index 397b2c779..1eb314b6e 100644 --- a/stdlib/source/test/lux/control/parser/analysis.lux +++ b/stdlib/source/test/lux/control/parser/analysis.lux @@ -23,7 +23,8 @@ ["." random (#+ Random)]] [tool [compiler - [reference (#+ Constant)] + [reference (#+ Constant) + [variable (#+)]] [language [lux ["." analysis]]]]]] diff --git a/stdlib/source/test/lux/control/region.lux b/stdlib/source/test/lux/control/region.lux index d911c15d5..b65590437 100644 --- a/stdlib/source/test/lux/control/region.lux +++ b/stdlib/source/test/lux/control/region.lux @@ -2,6 +2,7 @@ [lux #* ["_" test (#+ Test)] [abstract + [equivalence (#+ Equivalence)] [functor (#+ Functor)] [apply (#+ Apply)] ["." monad (#+ Monad do)] @@ -55,8 +56,16 @@ (def: comparison (Comparison (All [a] (All [! r] (Region r (Thread !) a)))) (function (_ == left right) - (case [(:assume (thread.run (:assume (/.run thread.monad left)))) - (:assume (thread.run (:assume (/.run thread.monad right))))] + (case [(:share [a] + {(Equivalence a) + ==} + {(Try a) + (thread.run (:assume (/.run thread.monad left)))}) + (:share [a] + {(Equivalence a) + ==} + {(Try a) + (thread.run (:assume (/.run thread.monad right)))})] [(#try.Success left) (#try.Success right)] (== left right) diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 5efd43701..702ea2272 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -8,10 +8,13 @@ ["." try] ["<>" parser ["<c>" code] - ["<a>" analysis]]] + ["<a>" analysis] + ["<s>" synthesis]]] [data ["." text ("#@." equivalence) - ["%" format (#+ format)]]] + ["%" format (#+ format)]] + [collection + ["." row]]] [tool [compiler ["." phase] @@ -32,37 +35,48 @@ (def: my-generation "my generation") (def: my-directive "my directive") +## Generation (`` (for {(~~ (static @.old)) - (as-is) - - (~~ (static @.jvm)) - (as-is (generation: (..my-generation self phase {parameters (<>.some <a>.any)}) - (#try.Success (#jvm.Constant (#jvm.LDC (#jvm.String Text))))))} - (as-is (analysis: (..my-analysis self phase {parameters (<>.some <c>.any)}) + (as-is)} + + (as-is (analysis: (..my-generation self phase archive {parameters (<>.some <c>.any)}) (do phase.monad [_ (type.infer .Text)] - (wrap (#analysis.Text self)))) + (wrap (#analysis.Extension self (list))))) - ## Synthesis - (analysis: (..my-synthesis self phase {parameters (<>.some <c>.any)}) + (synthesis: (..my-generation self phase archive {parameters (<>.some <a>.any)}) + (do phase.monad + [] + (wrap (#synthesis.Extension self (list))))) + ))) + +(`` (for {(~~ (static @.jvm)) + (as-is (generation: (..my-generation self phase archive {parameters (<>.some <s>.any)}) + (do phase.monad + [] + (wrap (row.row (#jvm.Constant (#jvm.LDC (#jvm.String self))))))))})) + +(`` (for {(~~ (static @.old)) + (as-is)} + + (as-is (analysis: (..my-analysis self phase archive {parameters (<>.some <c>.any)}) (do phase.monad [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) + (wrap (#analysis.Primitive (#analysis.Text self))))) - (synthesis: (..my-synthesis self phase {parameters (<>.some <a>.any)}) - (wrap (synthesis.text self))) - - ## Generation - (analysis: (..my-generation self phase {parameters (<>.some <c>.any)}) + ## Synthesis + (analysis: (..my-synthesis self phase archive {parameters (<>.some <c>.any)}) (do phase.monad [_ (type.infer .Text)] (wrap (#analysis.Extension self (list))))) - (synthesis: (..my-generation self phase {parameters (<>.some <a>.any)}) - (wrap (#synthesis.Extension self (list)))) - + (synthesis: (..my-synthesis self phase archive {parameters (<>.some <a>.any)}) + (do phase.monad + [] + (wrap (synthesis.text self)))) + ## Directive - (directive: (..my-directive self phase {parameters (<>.some <c>.any)}) + (directive: (..my-directive self phase archive {parameters (<>.some <c>.any)}) (do phase.monad [#let [_ (log! (format "Successfully installed directive " (%.text self) "!"))]] (wrap directive.no-requirements))) @@ -72,21 +86,18 @@ (def: #export test Test - (<| (_.context (%.name (name-of /._))) - ($_ _.and - (_.test "Can define and use analysis extensions." - (`` (for {(~~ (static @.old)) - false} - (text@= ((~~ (static ..my-analysis))) - ..my-analysis)))) - (_.test "Can define and use synthesis extensions." - (`` (for {(~~ (static @.old)) - false} - (text@= ((~~ (static ..my-synthesis))) - ..my-synthesis)))) - (_.test "Can define and use generation extensions." - (`` (for {(~~ (static @.old)) - false} - (text@= ((~~ (static ..my-generation))) - ..my-generation)))) - ))) + (<| (_.covering /._) + (`` ($_ _.and + (~~ (template [<macro> <extension>] + [(_.cover [<macro>] + (`` (for {(~~ (static @.old)) + false} + (text@= ((~~ (static <extension>))) + <extension>))))] + + [/.analysis: ..my-analysis] + [/.synthesis: ..my-synthesis] + [/.generation: ..my-generation])) + (_.cover [/.directive:] + true) + )))) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 0ccd4c5e3..6abfdb92d 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -1,6 +1,7 @@ (.module: [lux (#- Type type primitive int) ["." host (#+ import:)] + ["@" target] [abstract ["." monad (#+ do)]] [control @@ -138,12 +139,12 @@ (/type.class "java.lang.Boolean" (list))) (def: $Boolean::wrap (/.invokestatic ..$Boolean "valueOf" (/type.method [(list /type.boolean) ..$Boolean (list)]))) -(def: $Boolean::random (Random java/lang/Boolean) random.bit) +(def: $Boolean::random (:coerce (Random java/lang/Boolean) random.bit)) (def: !false (|> 0 .i64 i32.i32 /.int)) (def: !true (|> 1 .i64 i32.i32 /.int)) (def: ($Boolean::literal value) (-> java/lang/Boolean (Bytecode Any)) - (if value + (if (:coerce Bit value) ..!true ..!false)) (def: $Boolean::primitive @@ -160,10 +161,10 @@ (/.invokestatic ..$Byte "valueOf" (/type.method [(list /type.byte) ..$Byte (list)]))) (def: $Byte::random (Random java/lang/Byte) - (:: random.monad map (|>> host.long-to-byte) random.int)) + (:: random.monad map (|>> (:coerce java/lang/Long) host.long-to-byte) random.int)) (def: $Byte::literal (-> java/lang/Byte (Bytecode Any)) - (|>> host.byte-to-long .i64 i32.i32 /.int)) + (|>> host.byte-to-long (:coerce I64) i32.i32 /.int)) (def: $Byte::primitive (Primitive java/lang/Byte) {#unboxed /type.byte @@ -178,10 +179,10 @@ (/.invokestatic ..$Short "valueOf" (/type.method [(list /type.short) ..$Short (list)]))) (def: $Short::random (Random java/lang/Short) - (:: random.monad map (|>> host.long-to-short) random.int)) + (:: random.monad map (|>> (:coerce java/lang/Long) host.long-to-short) random.int)) (def: $Short::literal (-> java/lang/Short (Bytecode Any)) - (|>> host.short-to-long .i64 i32.i32 /.int)) + (|>> host.short-to-long (:coerce I64) i32.i32 /.int)) (def: $Short::primitive (Primitive java/lang/Short) {#unboxed /type.short @@ -196,10 +197,10 @@ (/.invokestatic ..$Integer "valueOf" (/type.method [(list /type.int) ..$Integer (list)]))) (def: $Integer::random (Random java/lang/Integer) - (:: random.monad map (|>> host.long-to-int) random.int)) + (:: random.monad map (|>> (:coerce java/lang/Long) host.long-to-int) random.int)) (def: $Integer::literal (-> java/lang/Integer (Bytecode Any)) - (|>> host.int-to-long .i64 i32.i32 /.int)) + (|>> host.int-to-long (:coerce I64) i32.i32 /.int)) (def: $Integer::primitive (Primitive java/lang/Integer) {#unboxed /type.int @@ -210,8 +211,8 @@ (def: $Long (/type.class "java.lang.Long" (list))) (def: $Long::wrap (/.invokestatic ..$Long "valueOf" (/type.method [(list /type.long) ..$Long (list)]))) -(def: $Long::random (Random java/lang/Long) random.int) -(def: $Long::literal (-> java/lang/Long (Bytecode Any)) /.long) +(def: $Long::random (:coerce (Random java/lang/Long) random.int)) +(def: $Long::literal (-> java/lang/Long (Bytecode Any)) (|>> (:coerce Int) /.long)) (def: $Long::primitive (Primitive java/lang/Long) {#unboxed /type.long @@ -225,7 +226,7 @@ (def: $Float::random (Random java/lang/Float) (:: random.monad map - (|>> (i.% +1024) i.frac host.double-to-float) + (|>> (i.% +1024) i.frac (:coerce java/lang/Double) host.double-to-float) random.int)) (def: $Float::literal /.float) (def: $Float::primitive @@ -238,8 +239,10 @@ (def: $Double (/type.class "java.lang.Double" (list))) (def: $Double::wrap (/.invokestatic ..$Double "valueOf" (/type.method [(list /type.double) ..$Double (list)]))) -(def: $Double::random random.frac) -(def: $Double::literal /.double) +(def: $Double::random (:coerce (Random java/lang/Double) random.frac)) +(def: $Double::literal + (-> java/lang/Double (Bytecode Any)) + (|>> (:coerce Frac) /.double)) (def: $Double::primitive (Primitive java/lang/Double) {#unboxed /type.double @@ -254,10 +257,10 @@ (/.invokestatic ..$Character "valueOf" (/type.method [(list /type.char) ..$Character (list)]))) (def: $Character::random (Random java/lang/Character) - (:: random.monad map (|>> host.long-to-int host.int-to-char) random.int)) + (:: random.monad map (|>> (:coerce java/lang/Long) host.long-to-int host.int-to-char) random.int)) (def: $Character::literal (-> java/lang/Character (Bytecode Any)) - (|>> host.char-to-long .i64 i32.i32 /.int)) + (|>> host.char-to-long (:coerce I64) i32.i32 /.int)) (def: $Character::primitive (Primitive java/lang/Character) {#unboxed /type.char @@ -266,9 +269,17 @@ #random ..$Character::random #literal ..$Character::literal}) -(def: $String (/type.class "java.lang.String" (list))) -(def: $String::random (random.ascii/alpha 10)) -(def: $String::literal /.string) +(def: $String + (/type.class "java.lang.String" (list))) + +(def: $String::random + (:coerce (Random java/lang/String) + (random.ascii/alpha 10))) + +(def: $String::literal + (-> java/lang/String (Bytecode Any)) + (|>> (:coerce Text) /.string)) + (def: $String::primitive (Primitive java/lang/String) {#unboxed ..$String @@ -277,34 +288,71 @@ #random ..$String::random #literal ..$String::literal}) -(template [<name> <bits> <type> <push> <wrap> <message> <to-long> <unsigned>] - [(def: <name> - Test - (do {@ random.monad} - [expected (:: @ map (i64.and (i64.mask <bits>)) random.nat)] - (<| (_.lift <message>) - (..bytecode (|>> (:coerce <type>) <to-long> ("jvm leq" expected))) - (do /.monad - [_ (<push> (|> expected <unsigned> try.assume))] - <wrap>))))] +(`` (with-expansions [<comparison> (for {(~~ (static @.old)) + "jvm leq" + (~~ (static @.jvm)) + "jvm long ="})] + (template [<name> <bits> <type> <push> <wrap> <message> <to-long> <unsigned>] + [(def: <name> + Test + (do {@ random.monad} + [expected (:: @ map (i64.and (i64.mask <bits>)) random.nat)] + (<| (_.lift <message>) + (..bytecode (for {(~~ (static @.old)) + (|>> (:coerce <type>) <to-long> (<comparison> expected)) + (~~ (static @.jvm)) + (|>> (:coerce <type>) <to-long> "jvm object cast" (<comparison> ("jvm object cast" (:coerce java/lang/Long expected))))})) + (do /.monad + [_ (<push> (|> expected <unsigned> try.assume))] + <wrap>))))] + + [byte 7 java/lang/Byte /.bipush ..$Byte::wrap "BIPUSH" host.byte-to-long /unsigned.u1] + [short 15 java/lang/Short /.sipush ..$Short::wrap "SIPUSH" host.short-to-long /unsigned.u2] + ))) + +(template [<name> <type>] + [(`` (template: (<name> <old-extension> <new-extension>) + (: (-> <type> <type> <type>) + (function (_ parameter subject) + (for {(~~ (static @.old)) + (<old-extension> subject parameter) + (~~ (static @.jvm)) + ("jvm object cast" + (<new-extension> ("jvm object cast" subject) + ("jvm object cast" parameter)))})))))] - [byte 7 java/lang/Byte /.bipush ..$Byte::wrap "BIPUSH" host.byte-to-long /unsigned.u1] - [short 15 java/lang/Short /.sipush ..$Short::wrap "SIPUSH" host.short-to-long /unsigned.u2] + [int/2 java/lang/Integer] + [long/2 java/lang/Long] + [float/2 java/lang/Float] + [double/2 java/lang/Double] ) -(template: (int/2 <extension>) - (: (-> java/lang/Integer java/lang/Integer java/lang/Integer) - (function (_ parameter subject) - (<extension> subject parameter)))) +(`` (template: (long+int/2 <old-extension> <new-extension>) + (: (-> java/lang/Integer java/lang/Long java/lang/Long) + (function (_ parameter subject) + (for {(~~ (static @.old)) + (<old-extension> subject parameter) + (~~ (static @.jvm)) + ("jvm object cast" + (<new-extension> ("jvm object cast" subject) + ("jvm object cast" parameter)))}))))) (def: int Test - (let [int (: (-> java/lang/Integer (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (|>> (:coerce java/lang/Integer) ("jvm ieq" expected))) - (do /.monad - [_ bytecode] - ..$Integer::wrap)))) + (let [int (`` (with-expansions [<comparison> (for {(~~ (static @.old)) + "jvm ieq" + (~~ (static @.jvm)) + "jvm int ="})] + (: (-> java/lang/Integer (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Integer) (<comparison> expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Integer) "jvm object cast" + (<comparison> ("jvm object cast" expected)))}))) + (do /.monad + [_ bytecode] + ..$Integer::wrap)))))) unary (: (-> (-> java/lang/Integer java/lang/Integer) (Bytecode Any) (Random Bit)) (function (_ reference instruction) (do random.monad @@ -328,7 +376,7 @@ shift (: (-> (-> java/lang/Integer java/lang/Integer java/lang/Integer) (Bytecode Any) (Random Bit)) (function (_ reference instruction) (do {@ random.monad} - [parameter (:: @ map (|>> (n.% 32) .int host.long-to-int) random.nat) + [parameter (:: @ map (|>> (n.% 32) .int (:coerce java/lang/Long) host.long-to-int) random.nat) subject ..$Integer::random] (int (reference parameter subject) (do /.monad @@ -336,33 +384,35 @@ _ (..$Integer::literal parameter)] instruction))))) literal ($_ _.and - (_.lift "ICONST_M1" (int (host.long-to-int -1) /.iconst-m1)) - (_.lift "ICONST_0" (int (host.long-to-int +0) /.iconst-0)) - (_.lift "ICONST_1" (int (host.long-to-int +1) /.iconst-1)) - (_.lift "ICONST_2" (int (host.long-to-int +2) /.iconst-2)) - (_.lift "ICONST_3" (int (host.long-to-int +3) /.iconst-3)) - (_.lift "ICONST_4" (int (host.long-to-int +4) /.iconst-4)) - (_.lift "ICONST_5" (int (host.long-to-int +5) /.iconst-5)) + (_.lift "ICONST_M1" (int (host.long-to-int (:coerce java/lang/Long -1)) /.iconst-m1)) + (_.lift "ICONST_0" (int (host.long-to-int (:coerce java/lang/Long +0)) /.iconst-0)) + (_.lift "ICONST_1" (int (host.long-to-int (:coerce java/lang/Long +1)) /.iconst-1)) + (_.lift "ICONST_2" (int (host.long-to-int (:coerce java/lang/Long +2)) /.iconst-2)) + (_.lift "ICONST_3" (int (host.long-to-int (:coerce java/lang/Long +3)) /.iconst-3)) + (_.lift "ICONST_4" (int (host.long-to-int (:coerce java/lang/Long +4)) /.iconst-4)) + (_.lift "ICONST_5" (int (host.long-to-int (:coerce java/lang/Long +5)) /.iconst-5)) (_.lift "LDC_W/INTEGER" (do random.monad [expected ..$Integer::random] (int expected (..$Integer::literal expected))))) arithmetic ($_ _.and - (_.lift "IADD" (binary (int/2 "jvm iadd") /.iadd)) - (_.lift "ISUB" (binary (int/2 "jvm isub") /.isub)) - (_.lift "IMUL" (binary (int/2 "jvm imul") /.imul)) - (_.lift "IDIV" (binary (int/2 "jvm idiv") /.idiv)) - (_.lift "IREM" (binary (int/2 "jvm irem") /.irem)) + (_.lift "IADD" (binary (int/2 "jvm iadd" "jvm int +") /.iadd)) + (_.lift "ISUB" (binary (int/2 "jvm isub" "jvm int -") /.isub)) + (_.lift "IMUL" (binary (int/2 "jvm imul" "jvm int *") /.imul)) + (_.lift "IDIV" (binary (int/2 "jvm idiv" "jvm int /") /.idiv)) + (_.lift "IREM" (binary (int/2 "jvm irem" "jvm int %") /.irem)) (_.lift "INEG" (unary (function (_ value) - ((int/2 "jvm isub") value (host.long-to-int +0))) + ((int/2 "jvm isub" "jvm int -") + value + (host.long-to-int (:coerce java/lang/Long +0)))) /.ineg))) bitwise ($_ _.and - (_.lift "IAND" (binary (int/2 "jvm iand") /.iand)) - (_.lift "IOR" (binary (int/2 "jvm ior") /.ior)) - (_.lift "IXOR" (binary (int/2 "jvm ixor") /.ixor)) - (_.lift "ISHL" (shift (int/2 "jvm ishl") /.ishl)) - (_.lift "ISHR" (shift (int/2 "jvm ishr") /.ishr)) - (_.lift "IUSHR" (shift (int/2 "jvm iushr") /.iushr)))] + (_.lift "IAND" (binary (int/2 "jvm iand" "jvm int and") /.iand)) + (_.lift "IOR" (binary (int/2 "jvm ior" "jvm int or") /.ior)) + (_.lift "IXOR" (binary (int/2 "jvm ixor" "jvm int xor") /.ixor)) + (_.lift "ISHL" (shift (int/2 "jvm ishl" "jvm int shl") /.ishl)) + (_.lift "ISHR" (shift (int/2 "jvm ishr" "jvm int shr") /.ishr)) + (_.lift "IUSHR" (shift (int/2 "jvm iushr" "jvm int ushr") /.iushr)))] ($_ _.and (<| (_.context "literal") literal) @@ -374,244 +424,291 @@ (def: long Test - (let [long (: (-> Int (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (|>> (:coerce Int) (i.= expected))) - (do /.monad - [_ bytecode] - ..$Long::wrap)))) - unary (: (-> (-> Int Int) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [subject ..$Long::random] - (long (reference subject) - (do /.monad - [_ (..$Long::literal subject)] - instruction))))) - binary (: (-> (-> Int Int Int) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [parameter ..$Long::random - subject ..$Long::random] - (long (reference parameter subject) + (`` (with-expansions [<comparison> (for {(~~ (static @.old)) + "jvm leq" + (~~ (static @.jvm)) + "jvm long ="})] + (let [long (: (-> java/lang/Long (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce Int) (i.= expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) (do /.monad - [_ (..$Long::literal subject) - _ (..$Long::literal parameter)] - instruction))))) - shift (: (-> (-> Nat Int Int) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do {@ random.monad} - [parameter (:: @ map (n.% 64) random.nat) - subject ..$Long::random] - (long (reference parameter subject) - (do /.monad - [_ (..$Long::literal subject) - _ (..$Integer::literal (host.long-to-int parameter))] - instruction))))) - literal ($_ _.and - (_.lift "LCONST_0" (long +0 /.lconst-0)) - (_.lift "LCONST_1" (long +1 /.lconst-1)) - (_.lift "LDC2_W/LONG" - (do random.monad - [expected ..$Long::random] - (long expected (..$Long::literal expected))))) - arithmetic ($_ _.and - (_.lift "LADD" (binary i.+ /.ladd)) - (_.lift "LSUB" (binary i.- /.lsub)) - (_.lift "LMUL" (binary i.* /.lmul)) - (_.lift "LDIV" (binary i./ /.ldiv)) - (_.lift "LREM" (binary i.% /.lrem)) - (_.lift "LNEG" (unary (function (_ value) (i.- value +0)) /.lneg))) - bitwise ($_ _.and - (_.lift "LAND" (binary i64.and /.land)) - (_.lift "LOR" (binary i64.or /.lor)) - (_.lift "LXOR" (binary i64.xor /.lxor)) - (_.lift "LSHL" (shift i64.left-shift /.lshl)) - (_.lift "LSHR" (shift i64.arithmetic-right-shift /.lshr)) - (_.lift "LUSHR" (shift i64.logic-right-shift /.lushr))) - comparison (_.lift "LCMP" - (do random.monad - [reference ..$Long::random - subject ..$Long::random - #let [expected (cond (i.= reference subject) - +0 - - (i.> reference subject) - +1 - - ## (i.< reference subject) - -1)]] - (<| (..bytecode (|>> (:coerce Int) (i.= expected))) + [_ bytecode] + ..$Long::wrap)))) + unary (: (-> (-> java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [subject ..$Long::random] + (long (reference subject) + (do /.monad + [_ (..$Long::literal subject)] + instruction))))) + binary (: (-> (-> java/lang/Long java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [parameter ..$Long::random + subject ..$Long::random] + (long (reference parameter subject) + (do /.monad + [_ (..$Long::literal subject) + _ (..$Long::literal parameter)] + instruction))))) + shift (: (-> (-> java/lang/Integer java/lang/Long java/lang/Long) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do {@ random.monad} + [parameter (:: @ map (|>> (n.% 64) (:coerce java/lang/Long)) random.nat) + subject ..$Long::random] + (long (reference (host.long-to-int parameter) subject) (do /.monad [_ (..$Long::literal subject) - _ (..$Long::literal reference) - _ /.lcmp - _ /.i2l] - ..$Long::wrap))))] - ($_ _.and - (<| (_.context "literal") - literal) - (<| (_.context "arithmetic") - arithmetic) - (<| (_.context "bitwise") - bitwise) - (<| (_.context "comparison") - comparison) - ))) + _ (..$Integer::literal (host.long-to-int parameter))] + instruction))))) + literal ($_ _.and + (_.lift "LCONST_0" (long (:coerce java/lang/Long +0) /.lconst-0)) + (_.lift "LCONST_1" (long (:coerce java/lang/Long +1) /.lconst-1)) + (_.lift "LDC2_W/LONG" + (do random.monad + [expected ..$Long::random] + (long expected (..$Long::literal expected))))) + arithmetic ($_ _.and + (_.lift "LADD" (binary (long/2 "jvm ladd" "jvm long +") /.ladd)) + (_.lift "LSUB" (binary (long/2 "jvm lsub" "jvm long -") /.lsub)) + (_.lift "LMUL" (binary (long/2 "jvm lmul" "jvm long *") /.lmul)) + (_.lift "LDIV" (binary (long/2 "jvm ldiv" "jvm long /") /.ldiv)) + (_.lift "LREM" (binary (long/2 "jvm lrem" "jvm long %") /.lrem)) + (_.lift "LNEG" (unary (function (_ value) + ((long/2 "jvm lsub" "jvm long -") + value + (:coerce java/lang/Long +0))) + /.lneg))) + bitwise ($_ _.and + (_.lift "LAND" (binary (long/2 "jvm land" "jvm long and") /.land)) + (_.lift "LOR" (binary (long/2 "jvm lor" "jvm long or") /.lor)) + (_.lift "LXOR" (binary (long/2 "jvm lxor" "jvm long xor") /.lxor)) + (_.lift "LSHL" (shift (long+int/2 "jvm lshl" "jvm long shl") /.lshl)) + (_.lift "LSHR" (shift (long+int/2 "jvm lshr" "jvm long shr") /.lshr)) + (_.lift "LUSHR" (shift (long+int/2 "jvm lushr" "jvm long ushr") /.lushr))) + comparison (_.lift "LCMP" + (do random.monad + [reference ..$Long::random + subject ..$Long::random + #let [expected (cond (i.= (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long +0) + + (i.> (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long +1) -(template: (float/2 <extension>) - (: (-> java/lang/Float java/lang/Float java/lang/Float) - (function (_ parameter subject) - (<extension> subject parameter)))) + ## (i.< (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long -1))]] + (<| (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce Int) (i.= expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) + (do /.monad + [_ (..$Long::literal subject) + _ (..$Long::literal reference) + _ /.lcmp + _ /.i2l] + ..$Long::wrap))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "bitwise") + bitwise) + (<| (_.context "comparison") + comparison) + ))))) (def: float Test - (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (|>> (:coerce java/lang/Float) ("jvm feq" expected))) - (do /.monad - [_ bytecode] - ..$Float::wrap)))) - unary (: (-> (-> java/lang/Float java/lang/Float) - (Bytecode Any) - (Random Bit)) - (function (_ reference instruction) - (do random.monad - [subject ..$Float::random] - (float (reference subject) - (do /.monad - [_ (..$Float::literal subject)] - instruction))))) - binary (: (-> (-> java/lang/Float java/lang/Float java/lang/Float) - (Bytecode Any) - (Random Bit)) - (function (_ reference instruction) - (do random.monad - [parameter ..$Float::random - subject ..$Float::random] - (float (reference parameter subject) + (`` (with-expansions [<comparison> (for {(~~ (static @.old)) + "jvm feq" + (~~ (static @.jvm)) + "jvm float ="})] + (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Float) ("jvm feq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Float) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) (do /.monad - [_ (..$Float::literal subject) - _ (..$Float::literal parameter)] - instruction))))) - literal ($_ _.and - (_.lift "FCONST_0" (float (host.double-to-float +0.0) /.fconst-0)) - (_.lift "FCONST_1" (float (host.double-to-float +1.0) /.fconst-1)) - (_.lift "FCONST_2" (float (host.double-to-float +2.0) /.fconst-2)) - (_.lift "LDC_W/FLOAT" - (do random.monad - [expected ..$Float::random] - (float expected (..$Float::literal expected))))) - arithmetic ($_ _.and - (_.lift "FADD" (binary (float/2 "jvm fadd") /.fadd)) - (_.lift "FSUB" (binary (float/2 "jvm fsub") /.fsub)) - (_.lift "FMUL" (binary (float/2 "jvm fmul") /.fmul)) - (_.lift "FDIV" (binary (float/2 "jvm fdiv") /.fdiv)) - (_.lift "FREM" (binary (float/2 "jvm frem") /.frem)) - (_.lift "FNEG" (unary (function (_ value) - ((float/2 "jvm fsub") value (host.double-to-float +0.0))) - /.fneg))) - comparison (: (-> (Bytecode Any) (-> java/lang/Float java/lang/Float Bit) (Random Bit)) - (function (_ instruction standard) - (do random.monad - [reference ..$Float::random - subject ..$Float::random - #let [expected (if ("jvm feq" reference subject) - +0 - (if (standard reference subject) - +1 - -1))]] - (<| (..bytecode (|>> (:coerce Int) (i.= expected))) - (do /.monad - [_ (..$Float::literal subject) - _ (..$Float::literal reference) - _ instruction - _ /.i2l] - ..$Long::wrap))))) - comparison ($_ _.and - (_.lift "FCMPL" (comparison /.fcmpl (function (_ reference subject) - ("jvm fgt" subject reference)))) - (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject) - ("jvm fgt" subject reference)))))] - ($_ _.and - (<| (_.context "literal") - literal) - (<| (_.context "arithmetic") - arithmetic) - (<| (_.context "comparison") - comparison) - ))) + [_ bytecode] + ..$Float::wrap)))) + unary (: (-> (-> java/lang/Float java/lang/Float) + (Bytecode Any) + (Random Bit)) + (function (_ reference instruction) + (do random.monad + [subject ..$Float::random] + (float (reference subject) + (do /.monad + [_ (..$Float::literal subject)] + instruction))))) + binary (: (-> (-> java/lang/Float java/lang/Float java/lang/Float) + (Bytecode Any) + (Random Bit)) + (function (_ reference instruction) + (do random.monad + [parameter ..$Float::random + subject ..$Float::random] + (float (reference parameter subject) + (do /.monad + [_ (..$Float::literal subject) + _ (..$Float::literal parameter)] + instruction))))) + literal ($_ _.and + (_.lift "FCONST_0" (float (host.double-to-float (:coerce java/lang/Double +0.0)) /.fconst-0)) + (_.lift "FCONST_1" (float (host.double-to-float (:coerce java/lang/Double +1.0)) /.fconst-1)) + (_.lift "FCONST_2" (float (host.double-to-float (:coerce java/lang/Double +2.0)) /.fconst-2)) + (_.lift "LDC_W/FLOAT" + (do random.monad + [expected ..$Float::random] + (float expected (..$Float::literal expected))))) + arithmetic ($_ _.and + (_.lift "FADD" (binary (float/2 "jvm fadd" "jvm float +") /.fadd)) + (_.lift "FSUB" (binary (float/2 "jvm fsub" "jvm float -") /.fsub)) + (_.lift "FMUL" (binary (float/2 "jvm fmul" "jvm float *") /.fmul)) + (_.lift "FDIV" (binary (float/2 "jvm fdiv" "jvm float /") /.fdiv)) + (_.lift "FREM" (binary (float/2 "jvm frem" "jvm float %") /.frem)) + (_.lift "FNEG" (unary (function (_ value) + ((float/2 "jvm fsub" "jvm float -") + value + (host.double-to-float (:coerce java/lang/Double +0.0)))) + /.fneg))) + comparison (: (-> (Bytecode Any) (-> java/lang/Float java/lang/Float Bit) (Random Bit)) + (function (_ instruction standard) + (do random.monad + [reference ..$Float::random + subject ..$Float::random + #let [expected (if (`` (for {(~~ (static @.old)) + ("jvm feq" reference subject) + (~~ (static @.jvm)) + (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))})) + +0 + (if (standard reference subject) + +1 + -1))]] + (<| (..bytecode (|>> (:coerce Int) (i.= expected))) + (do /.monad + [_ (..$Float::literal subject) + _ (..$Float::literal reference) + _ instruction + _ /.i2l] + ..$Long::wrap))))) + comparison ($_ _.and + (_.lift "FCMPL" (comparison /.fcmpl (function (_ reference subject) + (`` (for {(~~ (static @.old)) + ("jvm fgt" subject reference) + (~~ (static @.jvm)) + ("jvm float <" ("jvm object cast" reference) ("jvm object cast" subject))}))))) + (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject) + (`` (for {(~~ (static @.old)) + ("jvm fgt" subject reference) + (~~ (static @.jvm)) + ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))}))))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "comparison") + comparison) + ))))) (def: double Test - (let [double (: (-> Frac (Bytecode Any) (Random Bit)) - (function (_ expected bytecode) - (<| (..bytecode (|>> (:coerce Frac) (f.= expected))) - (do /.monad - [_ bytecode] - ..$Double::wrap)))) - unary (: (-> (-> Frac Frac) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [subject ..$Double::random] - (double (reference subject) - (do /.monad - [_ (..$Double::literal subject)] - instruction))))) - binary (: (-> (-> Frac Frac Frac) (Bytecode Any) (Random Bit)) - (function (_ reference instruction) - (do random.monad - [parameter ..$Double::random - subject ..$Double::random] - (double (reference parameter subject) - (do /.monad - [_ (..$Double::literal subject) - _ (..$Double::literal parameter)] - instruction))))) - literal ($_ _.and - (_.lift "DCONST_0" (double +0.0 /.dconst-0)) - (_.lift "DCONST_1" (double +1.0 /.dconst-1)) - (_.lift "LDC2_W/DOUBLE" - (do random.monad - [expected ..$Double::random] - (double expected (..$Double::literal expected))))) - arithmetic ($_ _.and - (_.lift "DADD" (binary f.+ /.dadd)) - (_.lift "DSUB" (binary f.- /.dsub)) - (_.lift "DMUL" (binary f.* /.dmul)) - (_.lift "DDIV" (binary f./ /.ddiv)) - (_.lift "DREM" (binary f.% /.drem)) - (_.lift "DNEG" (unary (function (_ value) (f.- value +0.0)) /.dneg))) - comparison (: (-> (Bytecode Any) (-> java/lang/Double java/lang/Double Bit) (Random Bit)) - (function (_ instruction standard) - (do random.monad - [reference ..$Double::random - subject ..$Double::random - #let [expected (if ("jvm deq" reference subject) - +0 - (if (standard reference subject) - +1 - -1))]] - (<| (..bytecode (|>> (:coerce Int) (i.= expected))) + (`` (with-expansions [<comparison> (for {(~~ (static @.old)) + "jvm deq" + (~~ (static @.jvm)) + "jvm double ="})] + (let [double (: (-> java/lang/Double (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Double) "jvm object cast" (<comparison> ("jvm object cast" expected)))}))) (do /.monad - [_ (..$Double::literal subject) - _ (..$Double::literal reference) - _ instruction - _ /.i2l] - ..$Long::wrap))))) - comparison ($_ _.and - (_.lift "DCMPL" (comparison /.dcmpl (function (_ reference subject) - ("jvm dgt" subject reference)))) - (_.lift "DCMPG" (comparison /.dcmpg (function (_ reference subject) - ("jvm dgt" subject reference)))))] - ($_ _.and - (<| (_.context "literal") - literal) - (<| (_.context "arithmetic") - arithmetic) - (<| (_.context "comparison") - comparison) - ))) + [_ bytecode] + ..$Double::wrap)))) + unary (: (-> (-> java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [subject ..$Double::random] + (double (reference subject) + (do /.monad + [_ (..$Double::literal subject)] + instruction))))) + binary (: (-> (-> java/lang/Double java/lang/Double java/lang/Double) (Bytecode Any) (Random Bit)) + (function (_ reference instruction) + (do random.monad + [parameter ..$Double::random + subject ..$Double::random] + (double (reference parameter subject) + (do /.monad + [_ (..$Double::literal subject) + _ (..$Double::literal parameter)] + instruction))))) + literal ($_ _.and + (_.lift "DCONST_0" (double (:coerce java/lang/Double +0.0) /.dconst-0)) + (_.lift "DCONST_1" (double (:coerce java/lang/Double +1.0) /.dconst-1)) + (_.lift "LDC2_W/DOUBLE" + (do random.monad + [expected ..$Double::random] + (double expected (..$Double::literal expected))))) + arithmetic ($_ _.and + (_.lift "DADD" (binary (double/2 "jvm dadd" "jvm double +") /.dadd)) + (_.lift "DSUB" (binary (double/2 "jvm dsub" "jvm double -") /.dsub)) + (_.lift "DMUL" (binary (double/2 "jvm dmul" "jvm double *") /.dmul)) + (_.lift "DDIV" (binary (double/2 "jvm ddiv" "jvm double /") /.ddiv)) + (_.lift "DREM" (binary (double/2 "jvm drem" "jvm double %") /.drem)) + (_.lift "DNEG" (unary (function (_ value) + ((double/2 "jvm dsub" "jvm double -") + value + (:coerce java/lang/Double +0.0))) + /.dneg))) + comparison (: (-> (Bytecode Any) (-> java/lang/Double java/lang/Double Bit) (Random Bit)) + (function (_ instruction standard) + (do random.monad + [reference ..$Double::random + subject ..$Double::random + #let [expected (if (`` (for {(~~ (static @.old)) + ("jvm deq" reference subject) + (~~ (static @.jvm)) + (<comparison> ("jvm object cast" reference) ("jvm object cast" subject))})) + +0 + (if (standard reference subject) + +1 + -1))]] + (<| (..bytecode (|>> (:coerce Int) (i.= expected))) + (do /.monad + [_ (..$Double::literal subject) + _ (..$Double::literal reference) + _ instruction + _ /.i2l] + ..$Long::wrap))))) + comparison ($_ _.and + (_.lift "DCMPL" (comparison /.dcmpl (function (_ reference subject) + (`` (for {(~~ (static @.old)) + ("jvm dlt" subject reference) + (~~ (static @.jvm)) + ("jvm double <" ("jvm object cast" reference) ("jvm object cast" subject))}))))) + (_.lift "DCMPG" (comparison /.dcmpg (function (_ reference subject) + (`` (for {(~~ (static @.old)) + ("jvm dgt" subject reference) + (~~ (static @.jvm)) + ("jvm double <" ("jvm object cast" subject) ("jvm object cast" reference))}))))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "comparison") + comparison) + ))))) (def: primitive Test @@ -649,7 +746,7 @@ [value ..$String::random]) (..bytecode (|>> (:coerce Bit))) (do /.monad - [_ (/.string value) + [_ (/.string (:coerce Text value)) _ (/.instanceof ..$String)] ..$Boolean::wrap)) (<| (_.lift "NEW & CHECKCAST") @@ -664,7 +761,7 @@ [value ..$String::random]) (..bytecode (|>> (:coerce Bit))) (do /.monad - [_ (/.string value) + [_ (/.string (:coerce Text value)) _ /.dup _ /.monitorenter _ /.dup _ /.monitorexit _ (/.instanceof ..$String)] @@ -677,35 +774,40 @@ (<| (_.lift "INVOKESTATIC") (do random.monad [expected ..$Double::random]) - (..bytecode (|>> (:coerce java/lang/Double) ("jvm deq" expected))) + (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))}))) (do /.monad - [_ (/.double expected)] + [_ (/.double (:coerce Frac expected))] (/.invokestatic ..$Double "valueOf" (/type.method [(list /type.double) ..$Double (list)])))) (<| (_.lift "INVOKEVIRTUAL") (do random.monad [expected ..$Double::random]) - (..bytecode (|>> (:coerce java/lang/Boolean) (bit@= (f.not-a-number? expected)))) + (..bytecode (|>> (:coerce Bit) (bit@= (f.not-a-number? (:coerce Frac expected))))) (do /.monad - [_ (/.double expected) + [_ (/.double (:coerce Frac expected)) _ ..$Double::wrap _ (/.invokevirtual ..$Double "isNaN" (/type.method [(list) /type.boolean (list)]))] ..$Boolean::wrap)) (<| (_.lift "INVOKESPECIAL") (do random.monad [expected ..$Double::random]) - (..bytecode (|>> (:coerce java/lang/Double) ("jvm deq" expected))) + (..bytecode (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))}))) (do /.monad [_ (/.new ..$Double) _ /.dup - _ (/.double expected)] + _ (/.double (:coerce Frac expected))] (/.invokespecial ..$Double "<init>" (/type.method [(list /type.double) /type.void (list)])))) (<| (_.lift "INVOKEINTERFACE") (do random.monad [subject ..$String::random]) - (..bytecode (|>> (:coerce java/lang/Long) - ("jvm leq" (text.size subject)))) + (..bytecode (|>> (:coerce Nat) (n.= (text.size (:coerce Text subject))))) (do /.monad - [_ (/.string subject) + [_ (/.string (:coerce Text subject)) _ (/.invokeinterface (/type.class "java.lang.CharSequence" (list)) "length" (/type.method [(list) /type.int (list)])) _ /.i2l] ..$Long::wrap)) @@ -717,7 +819,12 @@ [class-name ..class-name part0 ..$Long::random part1 ..$Long::random - #let [expected (i.+ part0 part1) + #let [expected (: java/lang/Long + (`` (for {(~~ (static @.old)) + ("jvm ladd" part0 part1) + (~~ (static @.jvm)) + ("jvm object cast" + ("jvm long +" ("jvm object cast" part0) ("jvm object cast" part1)))}))) $Self (/type.class class-name (list)) class-field "class_field" object-field "object_field" @@ -771,8 +878,8 @@ output (java/lang/reflect/Method::invoke (host.null) (host.array java/lang/Object 0) method)] (wrap (:coerce Int output))) (#try.Success actual) - (i.= expected actual) - + (i.= (:coerce Int expected) (:coerce Int actual)) + (#try.Failure error) false)))) @@ -781,7 +888,7 @@ (let [!length (: (-> Nat (Bytecode Any)) (function (_ size) (do /.monad - [_ ($Long::literal (.int size))] + [_ ($Long::literal (:coerce java/lang/Long size))] /.l2i))) ?length (: (Bytecode Any) (do /.monad @@ -802,7 +909,7 @@ (-> a Any Bit) (Random Bit))) (function (_ size constructor value literal [*store *load *wrap] test) - (let [!index ($Integer::literal (host.long-to-int +0))] + (let [!index ($Integer::literal (host.long-to-int (:coerce java/lang/Long +0)))] (<| (..bytecode (test value)) (do /.monad [_ (!length size) @@ -827,31 +934,59 @@ ($_ _.and (_.context "boolean" (array (/.newarray /instruction.t-boolean) $Boolean::random $Boolean::literal [/.bastore /.baload $Boolean::wrap] - (function (_ expected) (|>> (:coerce Bit) (bit@= expected))))) + (function (_ expected) (|>> (:coerce Bit) (bit@= (:coerce Bit expected)))))) (_.context "byte" (array (/.newarray /instruction.t-byte) $Byte::random $Byte::literal [/.bastore /.baload $Byte::wrap] - (function (_ expected) (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected)))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Byte) host.byte-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.byte-to-long (:coerce java/lang/Byte expected)))))}))))) (_.context "short" (array (/.newarray /instruction.t-short) $Short::random $Short::literal [/.sastore /.saload $Short::wrap] - (function (_ expected) (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected)))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Short) host.short-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.short-to-long (:coerce java/lang/Short expected)))))}))))) (_.context "int" (array (/.newarray /instruction.t-int) $Integer::random $Integer::literal [/.iastore /.iaload $Integer::wrap] - (function (_ expected) (|>> (:coerce java/lang/Integer) ("jvm ieq" expected))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Integer) ("jvm ieq" (host.int-to-long expected))) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Integer) "jvm object cast" ("jvm int =" ("jvm object cast" (:coerce java/lang/Integer expected))))}))))) (_.context "long" (array (/.newarray /instruction.t-long) $Long::random $Long::literal [/.lastore /.laload $Long::wrap] - (function (_ expected) (|>> (:coerce java/lang/Long) ("jvm leq" expected))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Long) ("jvm leq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Long) "jvm object cast" ("jvm long =" ("jvm object cast" (:coerce java/lang/Long expected))))}))))) (_.context "float" (array (/.newarray /instruction.t-float) $Float::random $Float::literal [/.fastore /.faload $Float::wrap] - (function (_ expected) (|>> (:coerce java/lang/Float) ("jvm feq" expected))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Float) ("jvm feq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Float) "jvm object cast" ("jvm float =" ("jvm object cast" (:coerce java/lang/Float expected))))}))))) (_.context "double" (array (/.newarray /instruction.t-double) $Double::random $Double::literal [/.dastore /.daload $Double::wrap] - (function (_ expected) (|>> (:coerce java/lang/Double) ("jvm deq" expected))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" (:coerce java/lang/Double expected))))}))))) (_.context "char" (array (/.newarray /instruction.t-char) $Character::random $Character::literal [/.castore /.caload $Character::wrap] - (function (_ expected) (|>> (:coerce java/lang/Character) ("jvm ceq" expected))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Character) ("jvm ceq" expected)) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Character) "jvm object cast" ("jvm char =" ("jvm object cast" (:coerce java/lang/Character expected))))}))))) (_.context "object" (array (/.anewarray ..$String) $String::random $String::literal [/.aastore /.aaload /.nop] - (function (_ expected) (|>> (:coerce Text) (text@= expected))))) + (function (_ expected) (|>> (:coerce Text) (text@= (:coerce Text expected)))))) (<| (_.context "multi") (do {@ random.monad} [#let [size (:: @ map (|>> (n.% 10) (n.+ 1)) @@ -866,15 +1001,23 @@ 0 type _ (recur (dec dimensions) (/type.array type))))]] (<| (_.lift "MULTIANEWARRAY") - (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" (.int sizesH)))) + (..bytecode (|>> (:coerce Nat) (n.= sizesH))) (do {@ /.monad} - [_ (monad.map @ (|>> host.long-to-int ..$Integer::literal) + [_ (monad.map @ (|>> (:coerce java/lang/Long) host.long-to-int ..$Integer::literal) (#.Cons sizesH sizesT)) _ (/.multianewarray type (|> dimensions /unsigned.u1 try.assume)) _ ?length] $Long::wrap)))) ))) +(template: (!::= <type> <old> <new>) + (: (-> <type> Any Bit) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce <type>) (<old> expected)) + (~~ (static @.jvm)) + (|>> (:coerce <type>) "jvm object cast" (<new> ("jvm object cast" (:coerce <type> expected))))}))))) + (def: conversion Test (let [conversion (: (All [a z] @@ -887,46 +1030,46 @@ (do /.monad [_ ((get@ #literal from) input) _ instruction] - (get@ #wrap to))))))] + (get@ #wrap to)))))) + int::= (!::= java/lang/Integer "jvm ieq" "jvm int =") + long::= (!::= java/lang/Long "jvm leq" "jvm long =") + float::= (!::= java/lang/Float "jvm feq" "jvm float =") + double::= (!::= java/lang/Double "jvm deq" "jvm double =")] ($_ _.and (<| (_.context "int") ($_ _.and - (_.lift "I2L" (conversion ..$Integer::primitive ..$Long::primitive /.i2l (|>> host.int-to-long) - (function (_ expected) (|>> (:coerce java/lang/Long) ("jvm leq" expected))))) - (_.lift "I2F" (conversion ..$Integer::primitive ..$Float::primitive /.i2f (|>> host.int-to-float) - (function (_ expected) (|>> (:coerce java/lang/Float) ("jvm feq" expected))))) - (_.lift "I2D" (conversion ..$Integer::primitive ..$Double::primitive /.i2d (|>> host.int-to-double) - (function (_ expected) (|>> (:coerce java/lang/Double) ("jvm deq" expected))))) + (_.lift "I2L" (conversion ..$Integer::primitive ..$Long::primitive /.i2l (|>> host.int-to-long) long::=)) + (_.lift "I2F" (conversion ..$Integer::primitive ..$Float::primitive /.i2f (|>> host.int-to-float) float::=)) + (_.lift "I2D" (conversion ..$Integer::primitive ..$Double::primitive /.i2d (|>> host.int-to-double) double::=)) (_.lift "I2B" (conversion ..$Integer::primitive ..$Byte::primitive /.i2b (|>> host.int-to-byte) - (function (_ expected) (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected)))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Byte) host.byte-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.byte-to-long (:coerce java/lang/Byte expected)))))}))))) (_.lift "I2C" (conversion ..$Integer::primitive ..$Character::primitive /.i2c (|>> host.int-to-char) - (function (_ expected) (|>> (:coerce java/lang/Character) ("jvm ceq" expected))))) + (!::= java/lang/Character "jvm ceq" "jvm char ="))) (_.lift "I2S" (conversion ..$Integer::primitive ..$Short::primitive /.i2s (|>> host.int-to-short) - (function (_ expected) (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected)))))))) + (function (_ expected) + (`` (for {(~~ (static @.old)) + (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) + (~~ (static @.jvm)) + (|>> (:coerce java/lang/Short) host.short-to-long "jvm object cast" ("jvm long =" ("jvm object cast" (host.short-to-long (:coerce java/lang/Short expected)))))}))))))) (<| (_.context "long") ($_ _.and - (_.lift "L2I" (conversion ..$Long::primitive ..$Integer::primitive /.l2i (|>> host.long-to-int) - (function (_ expected) (|>> (:coerce java/lang/Integer) ("jvm ieq" expected))))) - (_.lift "L2F" (conversion ..$Long::primitive ..$Float::primitive /.l2f (|>> host.long-to-float) - (function (_ expected) (|>> (:coerce java/lang/Float) ("jvm feq" expected))))) - (_.lift "L2D" (conversion ..$Long::primitive ..$Double::primitive /.l2d (|>> host.long-to-double) - (function (_ expected) (|>> (:coerce java/lang/Double) ("jvm deq" expected))))))) + (_.lift "L2I" (conversion ..$Long::primitive ..$Integer::primitive /.l2i (|>> host.long-to-int) int::=)) + (_.lift "L2F" (conversion ..$Long::primitive ..$Float::primitive /.l2f (|>> host.long-to-float) float::=)) + (_.lift "L2D" (conversion ..$Long::primitive ..$Double::primitive /.l2d (|>> host.long-to-double) double::=)))) (<| (_.context "float") ($_ _.and - (_.lift "F2I" (conversion ..$Float::primitive ..$Integer::primitive /.f2i (|>> host.float-to-int) - (function (_ expected) (|>> (:coerce java/lang/Integer) ("jvm ieq" expected))))) - (_.lift "F2L" (conversion ..$Float::primitive ..$Long::primitive /.f2l (|>> host.float-to-long) - (function (_ expected) (|>> (:coerce java/lang/Long) ("jvm leq" expected))))) - (_.lift "F2D" (conversion ..$Float::primitive ..$Double::primitive /.f2d (|>> host.float-to-double) - (function (_ expected) (|>> (:coerce java/lang/Double) ("jvm deq" expected))))))) + (_.lift "F2I" (conversion ..$Float::primitive ..$Integer::primitive /.f2i (|>> host.float-to-int) int::=)) + (_.lift "F2L" (conversion ..$Float::primitive ..$Long::primitive /.f2l (|>> host.float-to-long) long::=)) + (_.lift "F2D" (conversion ..$Float::primitive ..$Double::primitive /.f2d (|>> host.float-to-double) double::=)))) (<| (_.context "double") ($_ _.and - (_.lift "D2I" (conversion ..$Double::primitive ..$Integer::primitive /.d2i (|>> host.double-to-int) - (function (_ expected) (|>> (:coerce java/lang/Integer) ("jvm ieq" expected))))) - (_.lift "D2L" (conversion ..$Double::primitive ..$Long::primitive /.d2l (|>> host.double-to-long) - (function (_ expected) (|>> (:coerce java/lang/Long) ("jvm leq" expected))))) - (_.lift "D2F" (conversion ..$Double::primitive ..$Float::primitive /.d2f (|>> host.double-to-float) - (function (_ expected) (|>> (:coerce java/lang/Float) ("jvm feq" expected))))))) + (_.lift "D2I" (conversion ..$Double::primitive ..$Integer::primitive /.d2i (|>> host.double-to-int) int::=)) + (_.lift "D2L" (conversion ..$Double::primitive ..$Long::primitive /.d2l (|>> host.double-to-long) long::=)) + (_.lift "D2F" (conversion ..$Double::primitive ..$Float::primitive /.d2f (|>> host.double-to-float) float::=)))) ))) (def: value @@ -948,27 +1091,7 @@ (def: registry Test - (let [add-registers (: (All [a] - (-> (Random a) (-> a (Bytecode Any)) (Bytecode Any) (Bytecode Any) - (-> a a (-> Any Bit)) - [(Bytecode Any) (Bytecode Any)] - [(Bytecode Any) (Bytecode Any)] - (Random Bit))) - (function (_ random-value literal *add *wrap test [!parameter ?parameter] [!subject ?subject]) - (do random.monad - [subject random-value - parameter random-value] - (<| (..bytecode (test parameter subject)) - (do /.monad - [_ (literal subject) - _ !subject - _ (literal parameter) - _ !parameter - _ ?subject - _ ?parameter - _ *add] - *wrap))))) - store-and-load (: (All [a] + (let [store-and-load (: (All [a] (-> (Random a) (-> a (Bytecode Any)) (Bytecode Any) [(-> Nat (Bytecode Any)) (-> Nat (Bytecode Any))] (-> a (-> Any Bit)) @@ -985,28 +1108,34 @@ *wrap)))))] ($_ _.and (<| (_.context "int") - (let [test-int (: (-> java/lang/Integer java/lang/Integer (-> Any Bit)) - (function (_ parameter subject) - (|>> (:coerce java/lang/Integer) ("jvm ieq" ("jvm iadd" parameter subject))))) - add-int-registers (add-registers ..$Integer::random ..$Integer::literal /.iadd ..$Integer::wrap test-int)] + (let [test (!::= java/lang/Integer "jvm ieq" "jvm int =")] ($_ _.and - (_.lift "ISTORE_0/ILOAD_0 & ISTORE_2/ILOAD_2" - (add-int-registers [/.istore-2 /.iload-2] [/.istore-0 /.iload-0])) - (_.lift "ISTORE_1/ILOAD_1 & ISTORE_3/ILOAD_3" - (add-int-registers [/.istore-3 /.iload-3] [/.istore-1 /.iload-1])) + (_.lift "ISTORE_0/ILOAD_0" + (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [(function.constant /.istore-0) (function.constant /.iload-0)] test)) + (_.lift "ISTORE_1/ILOAD_1" + (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [(function.constant /.istore-1) (function.constant /.iload-1)] test)) + (_.lift "ISTORE_2/ILOAD_2" + (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [(function.constant /.istore-2) (function.constant /.iload-2)] test)) + (_.lift "ISTORE_3/ILOAD_3" + (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [(function.constant /.istore-3) (function.constant /.iload-3)] test)) (_.lift "ISTORE/ILOAD" - (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [/.istore /.iload] - (function (_ expected actual) - (|> actual (:coerce java/lang/Integer) ("jvm ieq" expected))))) + (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [/.istore /.iload] test)) (_.lift "IINC" (do {@ random.monad} [base ..$Byte::random increment (:: @ map (|>> (n.% 100) /unsigned.u1 try.assume) random.nat) - #let [expected ("jvm ladd" - (host.byte-to-long base) - (.int (/unsigned.value increment)))]] - (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected)) + #let [expected (: java/lang/Long + (`` (for {(~~ (static @.old)) + ("jvm ladd" + (host.byte-to-long base) + (.int (/unsigned.value increment))) + (~~ (static @.jvm)) + ("jvm object cast" + ("jvm long +" + ("jvm object cast" (host.byte-to-long base)) + ("jvm object cast" (:coerce java/lang/Long (/unsigned.value increment)))))})))]] + (..bytecode (|>> (:coerce Int) (i.= (:coerce Int expected))) (do /.monad [_ (..$Byte::literal base) _ /.istore-0 @@ -1015,89 +1144,84 @@ _ /.i2l] ..$Long::wrap))))))) (<| (_.context "long") - (let [test-long (: (-> Int Int (-> Any Bit)) - (function (_ parameter subject) - (|>> (:coerce Int) (i.= (i.+ parameter subject))))) - add-long-registers (add-registers ..$Long::random ..$Long::literal /.ladd ..$Long::wrap test-long)] + (let [test (!::= java/lang/Long "jvm leq" "jvm long =")] ($_ _.and - (_.lift "LSTORE_0/LLOAD_0 & LSTORE_2/LLOAD_2" - (add-long-registers [/.lstore-2 /.lload-2] [/.lstore-0 /.lload-0])) - (_.lift "LSTORE_1/LLOAD_1 & LSTORE_3/LLOAD_3" - (add-long-registers [/.lstore-3 /.lload-3] [/.lstore-1 /.lload-1])) + (_.lift "LSTORE_0/LLOAD_0" + (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [(function.constant /.lstore-0) (function.constant /.lload-0)] test)) + (_.lift "LSTORE_1/LLOAD_1" + (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [(function.constant /.lstore-1) (function.constant /.lload-1)] test)) + (_.lift "LSTORE_2/LLOAD_2" + (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [(function.constant /.lstore-2) (function.constant /.lload-2)] test)) + (_.lift "LSTORE_3/LLOAD_3" + (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [(function.constant /.lstore-3) (function.constant /.lload-3)] test)) (_.lift "LSTORE/LLOAD" - (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [/.lstore /.lload] - (function (_ expected actual) - (|> actual (:coerce java/lang/Long) ("jvm leq" expected)))))))) + (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [/.lstore /.lload] test))))) (<| (_.context "float") - (let [test-float (: (-> java/lang/Float java/lang/Float (-> Any Bit)) - (function (_ parameter subject) - (|>> (:coerce java/lang/Float) ("jvm feq" ("jvm fadd" parameter subject))))) - add-float-registers (add-registers ..$Float::random ..$Float::literal /.fadd ..$Float::wrap test-float)] + (let [test (!::= java/lang/Float "jvm feq" "jvm float =")] ($_ _.and - (_.lift "FSTORE_0/FLOAD_0 & FSTORE_2/FLOAD_2" - (add-float-registers [/.fstore-2 /.fload-2] [/.fstore-0 /.fload-0])) - (_.lift "FSTORE_1/FLOAD_1 & FSTORE_3/FLOAD_3" - (add-float-registers [/.fstore-3 /.fload-3] [/.fstore-1 /.fload-1])) + (_.lift "FSTORE_0/FLOAD_0" + (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [(function.constant /.fstore-0) (function.constant /.fload-0)] test)) + (_.lift "FSTORE_1/FLOAD_1" + (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [(function.constant /.fstore-1) (function.constant /.fload-1)] test)) + (_.lift "FSTORE_2/FLOAD_2" + (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [(function.constant /.fstore-2) (function.constant /.fload-2)] test)) + (_.lift "FSTORE_3/FLOAD_3" + (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [(function.constant /.fstore-3) (function.constant /.fload-3)] test)) (_.lift "FSTORE/FLOAD" - (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [/.fstore /.fload] - (function (_ expected actual) - (|> actual (:coerce java/lang/Float) ("jvm feq" expected)))))))) + (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [/.fstore /.fload] test))))) (<| (_.context "double") - (let [test-double (: (-> Frac Frac (-> Any Bit)) - (function (_ parameter subject) - (|>> (:coerce Frac) (f.= (f.+ parameter subject))))) - add-double-registers (add-registers ..$Double::random ..$Double::literal /.dadd ..$Double::wrap test-double)] + (let [test (!::= java/lang/Double "jvm deq" "jvm double =")] ($_ _.and - (_.lift "DSTORE_0/DLOAD_0 & DSTORE_2/DLOAD_2" - (add-double-registers [/.dstore-2 /.dload-2] [/.dstore-0 /.dload-0])) - (_.lift "DSTORE_1/DLOAD_1 & DSTORE_3/DLOAD_3" - (add-double-registers [/.dstore-3 /.dload-3] [/.dstore-1 /.dload-1])) + (_.lift "DSTORE_0/DLOAD_0" + (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-0) (function.constant /.dload-0)] test)) + (_.lift "DSTORE_1/DLOAD_1" + (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-1) (function.constant /.dload-1)] test)) + (_.lift "DSTORE_2/DLOAD_2" + (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-2) (function.constant /.dload-2)] test)) + (_.lift "DSTORE_3/DLOAD_3" + (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [(function.constant /.dstore-3) (function.constant /.dload-3)] test)) (_.lift "DSTORE/DLOAD" - (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [/.dstore /.dload] - (function (_ expected actual) - (|> actual (:coerce java/lang/Double) ("jvm deq" expected)))))))) + (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [/.dstore /.dload] test))))) (<| (_.context "object") - (let [test (function (_ expected actual) - (|> actual (:coerce Text) (text@= expected)))] + (let [test (: (-> java/lang/String Any Bit) + (function (_ expected actual) + (|> actual (:coerce Text) (text@= (:coerce Text expected)))))] ($_ _.and (_.lift "ASTORE_0/ALOAD_0" - (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-0) (function.constant /.aload-0)] - test)) + (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-0) (function.constant /.aload-0)] test)) (_.lift "ASTORE_1/ALOAD_1" - (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-1) (function.constant /.aload-1)] - test)) + (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-1) (function.constant /.aload-1)] test)) (_.lift "ASTORE_2/ALOAD_2" - (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-2) (function.constant /.aload-2)] - test)) + (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-2) (function.constant /.aload-2)] test)) (_.lift "ASTORE_3/ALOAD_3" - (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-3) (function.constant /.aload-3)] - test)) + (store-and-load ..$String::random ..$String::literal /.nop [(function.constant /.astore-3) (function.constant /.aload-3)] test)) (_.lift "ASTORE/ALOAD" - (store-and-load ..$String::random ..$String::literal /.nop [/.astore /.aload] - test))))) + (store-and-load ..$String::random ..$String::literal /.nop [/.astore /.aload] test))))) ))) (def: stack Test (do random.monad [expected/1 $String::random + #let [object-test (: (-> Any Bit) + (|>> (:coerce Text) (text@= (:coerce Text expected/1))))] dummy/1 $String::random #let [single ($_ _.and (<| (_.lift "DUP & POP") - (..bytecode (|>> (:coerce Text) (text@= expected/1))) + (..bytecode object-test) (do /.monad [_ ($String::literal expected/1) _ /.dup] /.pop)) (<| (_.lift "DUP_X1 & POP2") - (..bytecode (|>> (:coerce Text) (text@= expected/1))) + (..bytecode object-test) (do /.monad [_ ($String::literal dummy/1) _ ($String::literal expected/1) _ /.dup-x1] /.pop2)) (<| (_.lift "DUP_X2") - (..bytecode (|>> (:coerce Text) (text@= expected/1))) + (..bytecode object-test) (do /.monad [_ ($String::literal dummy/1) _ ($String::literal dummy/1) @@ -1106,7 +1230,7 @@ _ /.pop2] /.pop)) (<| (_.lift "SWAP") - (..bytecode (|>> (:coerce Text) (text@= expected/1))) + (..bytecode object-test) (do /.monad [_ ($String::literal dummy/1) _ ($String::literal expected/1) @@ -1114,17 +1238,19 @@ /.pop)) )] expected/2 $Long::random + #let [long-test (: (-> Any Bit) + (|>> (:coerce Int) (i.= (:coerce Int expected/2))))] dummy/2 $Long::random #let [double ($_ _.and (<| (_.lift "DUP2") - (..bytecode (|>> (:coerce Int) (i.= expected/2))) + (..bytecode long-test) (do /.monad [_ ($Long::literal expected/2) _ /.dup2 _ /.pop2] ..$Long::wrap)) (<| (_.lift "DUP2_X1") - (..bytecode (|>> (:coerce Int) (i.= expected/2))) + (..bytecode long-test) (do /.monad [_ ($String::literal dummy/1) _ ($Long::literal expected/2) @@ -1133,7 +1259,7 @@ _ /.pop] ..$Long::wrap)) (<| (_.lift "DUP2_X2") - (..bytecode (|>> (:coerce Int) (i.= expected/2))) + (..bytecode long-test) (do /.monad [_ ($Long::literal dummy/2) _ ($Long::literal expected/2) @@ -1206,16 +1332,16 @@ (java/lang/reflect/Method::invoke (host.null) (host.array java/lang/Object 0) method)) (#try.Success actual) (test expected actual) - + (#try.Failure error) false) ))))] ($_ _.and - (_.lift "IRETURN" (primitive-return ..$Integer::primitive /.ireturn #.None (function (_ expected actual) ("jvm ieq" expected (:coerce java/lang/Integer actual))))) - (_.lift "LRETURN" (primitive-return ..$Long::primitive /.lreturn #.None (function (_ expected actual) ("jvm leq" expected (:coerce java/lang/Long actual))))) - (_.lift "FRETURN" (primitive-return ..$Float::primitive /.freturn #.None (function (_ expected actual) ("jvm feq" expected (:coerce java/lang/Float actual))))) - (_.lift "DRETURN" (primitive-return ..$Double::primitive /.dreturn #.None (function (_ expected actual) ("jvm deq" expected (:coerce java/lang/Double actual))))) - (_.lift "ARETURN" (primitive-return ..$String::primitive /.areturn #.None (function (_ expected actual) (text@= expected (:coerce java/lang/String actual))))) + (_.lift "IRETURN" (primitive-return ..$Integer::primitive /.ireturn #.None (!::= java/lang/Integer "jvm ieq" "jvm int ="))) + (_.lift "LRETURN" (primitive-return ..$Long::primitive /.lreturn #.None (!::= java/lang/Long "jvm leq" "jvm long ="))) + (_.lift "FRETURN" (primitive-return ..$Float::primitive /.freturn #.None (!::= java/lang/Float "jvm feq" "jvm float ="))) + (_.lift "DRETURN" (primitive-return ..$Double::primitive /.dreturn #.None (!::= java/lang/Double "jvm deq" "jvm double ="))) + (_.lift "ARETURN" (primitive-return ..$String::primitive /.areturn #.None (function (_ expected actual) (text@= (:coerce Text expected) (:coerce Text actual))))) (_.lift "RETURN" (primitive-return (: (Primitive java/lang/String) {#unboxed /type.void #boxed ..$String @@ -1224,7 +1350,7 @@ #literal (function.constant /.nop)}) /.return (#.Some ..$String::literal) - (function (_ expected actual) (text@= expected (:coerce java/lang/String actual))))) + (function (_ expected actual) (text@= (:coerce Text expected) (:coerce Text actual))))) ))) (def: branching @@ -1234,7 +1360,7 @@ dummy ..$Long::random #let [if! (: (-> (-> Label (Bytecode Any)) (Bytecode Any) (Random Bit)) (function (_ instruction prelude) - (<| (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (<| (..bytecode ((!::= java/lang/Long "jvm leq" "jvm long =") expected)) (do /.monad [@then /.new-label @end /.new-label @@ -1258,8 +1384,11 @@ (_.lift "IFNONNULL" (if! /.ifnonnull (/.string ""))))] reference ..$Integer::random subject (|> ..$Integer::random - (random.filter (|>> ("jvm ieq" reference) not))) - #let [[lesser greater] (if ("jvm ilt" reference subject) + (random.filter (|>> ((!::= java/lang/Integer "jvm ieq" "jvm int =") reference) not))) + #let [[lesser greater] (if (`` (for {(~~ (static @.old)) + ("jvm ilt" reference subject) + (~~ (static @.jvm)) + ("jvm int <" ("jvm object cast" subject) ("jvm object cast" reference))})) [reference subject] [subject reference]) int-comparison ($_ _.and @@ -1292,7 +1421,7 @@ dummy ..$Long::random #let [jump (: (-> (-> Label (Bytecode Any)) (Random Bit)) (function (_ goto) - (<| (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (<| (..bytecode ((!::= java/lang/Long "jvm leq" "jvm long =") expected)) (do /.monad [@skipped /.new-label @value /.new-label @@ -1319,7 +1448,7 @@ minimum (:: @ map (|>> (n.% 100) .int /signed.s4 try.assume) random.nat) afterwards (:: @ map (n.% 10) random.nat)]) - (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (..bytecode ((!::= java/lang/Long "jvm leq" "jvm long =") expected)) (do /.monad [@right /.new-label @wrong /.new-label @@ -1339,18 +1468,18 @@ random.nat) choice (:: @ map (n.% options) random.nat) options (|> random.int - (:: @ map (|>> host.long-to-int host.int-to-long)) + (:: @ map (|>> (:coerce java/lang/Long) host.long-to-int host.int-to-long (:coerce Int))) (random.set i.hash options) (:: @ map set.to-list)) #let [choice (maybe.assume (list.nth choice options))] expected ..$Long::random dummy ..$Long::random]) - (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (..bytecode ((!::= java/lang/Long "jvm leq" "jvm long =") expected)) (do /.monad [@right /.new-label @wrong /.new-label @return /.new-label - _ (..$Integer::literal (host.long-to-int choice)) + _ (..$Integer::literal (host.long-to-int (:coerce java/lang/Long choice))) _ (/.lookupswitch @wrong (list@map (function (_ option) [(|> option /signed.s4 try.assume) (if (i.= choice option) @right @wrong)]) @@ -1371,7 +1500,7 @@ dummy ..$Long::random exception ..$String::random] (<| (_.lift "ATHROW") - (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" expected))) + (..bytecode ((!::= java/lang/Long "jvm leq" "jvm long =") expected)) (do /.monad [#let [$Exception (/type.class "java.lang.Exception" (list))] @skipped /.new-label @@ -1437,12 +1566,11 @@ part3 ..$Long::random part4 ..$Long::random #let [expected ($_ i.+ - part0 - part1 - part2 - part3 - part4 - ) + (:coerce Int part0) + (:coerce Int part1) + (:coerce Int part2) + (:coerce Int part3) + (:coerce Int part4)) $Concrete (/type.class concrete-class (list)) $Abstract (/type.class abstract-class (list)) $Interface (/type.class interface-class (list)) @@ -1555,8 +1683,8 @@ output (java/lang/reflect/Method::invoke (host.null) (host.array java/lang/Object 0) method)] (wrap (:coerce Int output))) (#try.Success actual) - (i.= expected actual) - + (i.= (:coerce Int expected) (:coerce Int actual)) + (#try.Failure error) false)))) |