diff options
Diffstat (limited to 'stdlib/source/test')
| -rw-r--r-- | stdlib/source/test/lux.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/test/lux/extension.lux | 90 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/jvm.lux | 806 |
3 files changed, 462 insertions, 442 deletions
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 14360da93..e2d9fb258 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -315,10 +315,10 @@ on-default))) (_.test "Can pick code depending on the host/platform being targeted." (n.= on-valid-host - (`` (for {(~~ (static @.old)) on-valid-host - (~~ (static @.jvm)) on-valid-host - (~~ (static @.js)) on-valid-host} - on-default))))))) + (for {@.old on-valid-host + @.jvm on-valid-host + @.js on-valid-host} + on-default)))))) (def: test (<| (_.context (name.module (name-of /._))) diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 702ea2272..da6f89187 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -36,53 +36,53 @@ (def: my-directive "my directive") ## Generation -(`` (for {(~~ (static @.old)) - (as-is)} - - (as-is (analysis: (..my-generation self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) +(for {@.old + (as-is)} + + (as-is (analysis: (..my-generation self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [_ (type.infer .Text)] + (wrap (#analysis.Extension self (list))))) - (synthesis: (..my-generation self phase archive {parameters (<>.some <a>.any)}) - (do phase.monad - [] - (wrap (#synthesis.Extension self (list))))) - ))) + (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 {@.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.Primitive (#analysis.Text self))))) +(for {@.old + (as-is)} + + (as-is (analysis: (..my-analysis self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [_ (type.infer .Text)] + (wrap (#analysis.Primitive (#analysis.Text self))))) - ## Synthesis - (analysis: (..my-synthesis self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) + ## Synthesis + (analysis: (..my-synthesis self phase archive {parameters (<>.some <c>.any)}) + (do phase.monad + [_ (type.infer .Text)] + (wrap (#analysis.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 archive {parameters (<>.some <c>.any)}) - (do phase.monad - [#let [_ (log! (format "Successfully installed directive " (%.text self) "!"))]] - (wrap directive.no-requirements))) + (synthesis: (..my-synthesis self phase archive {parameters (<>.some <a>.any)}) + (do phase.monad + [] + (wrap (synthesis.text self)))) + + ## Directive + (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))) - (`` ((~~ (static ..my-directive)))) - ))) + (`` ((~~ (static ..my-directive)))) + )) (def: #export test Test @@ -90,10 +90,10 @@ (`` ($_ _.and (~~ (template [<macro> <extension>] [(_.cover [<macro>] - (`` (for {(~~ (static @.old)) - false} - (text@= ((~~ (static <extension>))) - <extension>))))] + (for {@.old + false} + (text@= (`` ((~~ (static <extension>)))) + <extension>)))] [/.analysis: ..my-analysis] [/.synthesis: ..my-synthesis] diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index 6abfdb92d..f572b7e1e 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -288,38 +288,39 @@ #random ..$String::random #literal ..$String::literal}) -(`` (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>))))] +(with-expansions [<comparison> (for {@.old + "jvm leq" + @.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 {@.old + (|>> (:coerce <type>) <to-long> (<comparison> expected)) + @.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] - ))) + [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)))})))))] + [(template: (<name> <old-extension> <new-extension>) + (: (-> <type> <type> <type>) + (function (_ parameter subject) + (for {@.old + (<old-extension> subject parameter) + + @.jvm + ("jvm object cast" + (<new-extension> ("jvm object cast" subject) + ("jvm object cast" parameter)))}))))] [int/2 java/lang/Integer] [long/2 java/lang/Long] @@ -327,32 +328,32 @@ [double/2 java/lang/Double] ) -(`` (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)))}))))) +(template: (long+int/2 <old-extension> <new-extension>) + (: (-> java/lang/Integer java/lang/Long java/lang/Long) + (function (_ parameter subject) + (for {@.old + (<old-extension> subject parameter) + + @.jvm + ("jvm object cast" + (<new-extension> ("jvm object cast" subject) + ("jvm object cast" parameter)))})))) (def: int Test - (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)))))) + (let [int (with-expansions [<comparison> (for {@.old "jvm ieq" + @.jvm "jvm int ="})] + (: (-> java/lang/Integer (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce java/lang/Integer) (<comparison> expected)) + + @.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 @@ -424,291 +425,295 @@ (def: long Test - (`` (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 - [_ 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) - _ (..$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) + (with-expansions [<comparison> (for {@.old "jvm leq" + @.jvm "jvm long ="})] + (let [long (: (-> java/lang/Long (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce Int) (i.= expected)) + + @.jvm + (|>> (:coerce java/lang/Long) "jvm object cast" (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ 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) + _ (..$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) + (i.> (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long +1) - ## (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) - ))))) + ## (i.< (:coerce Int reference) (:coerce Int subject)) + (:coerce java/lang/Long -1))]] + (<| (..bytecode (for {@.old + (|>> (:coerce Int) (i.= expected)) + + @.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 - (`` (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 - [_ 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) + (with-expansions [<comparison> (for {@.old "jvm feq" + @.jvm "jvm float ="})] + (let [float (: (-> java/lang/Float (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce java/lang/Float) ("jvm feq" expected)) + + @.jvm + (|>> (:coerce java/lang/Float) "jvm object cast" (<comparison> ("jvm object cast" 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) + (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 - [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) - ))))) + [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 {@.old + ("jvm feq" reference subject) + + @.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 {@.old + ("jvm fgt" subject reference) + + @.jvm + ("jvm float <" ("jvm object cast" reference) ("jvm object cast" subject))})))) + (_.lift "FCMPG" (comparison /.fcmpg (function (_ reference subject) + (for {@.old + ("jvm fgt" subject reference) + + @.jvm + ("jvm float <" ("jvm object cast" subject) ("jvm object cast" reference))})))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "comparison") + comparison) + )))) (def: double Test - (`` (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 - [_ 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) + (with-expansions [<comparison> (for {@.old "jvm deq" + @.jvm "jvm double ="})] + (let [double (: (-> java/lang/Double (Bytecode Any) (Random Bit)) + (function (_ expected bytecode) + (<| (..bytecode (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" (<comparison> ("jvm object cast" expected)))})) + (do /.monad + [_ 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 - [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) - ))))) + [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 {@.old + ("jvm deq" reference subject) + + @.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 {@.old + ("jvm dlt" subject reference) + + @.jvm + ("jvm double <" ("jvm object cast" reference) ("jvm object cast" subject))})))) + (_.lift "DCMPG" (comparison /.dcmpg (function (_ reference subject) + (for {@.old + ("jvm dgt" subject reference) + + @.jvm + ("jvm double <" ("jvm object cast" subject) ("jvm object cast" reference))})))))] + ($_ _.and + (<| (_.context "literal") + literal) + (<| (_.context "arithmetic") + arithmetic) + (<| (_.context "comparison") + comparison) + )))) (def: primitive Test @@ -774,10 +779,11 @@ (<| (_.lift "INVOKESTATIC") (do random.monad [expected ..$Double::random]) - (..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)))}))) + (..bytecode (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))})) (do /.monad [_ (/.double (:coerce Frac expected))] (/.invokestatic ..$Double "valueOf" (/type.method [(list /type.double) ..$Double (list)])))) @@ -793,10 +799,11 @@ (<| (_.lift "INVOKESPECIAL") (do random.monad [expected ..$Double::random]) - (..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)))}))) + (..bytecode (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.jvm + (|>> (:coerce java/lang/Double) "jvm object cast" ("jvm double =" ("jvm object cast" expected)))})) (do /.monad [_ (/.new ..$Double) _ /.dup @@ -820,11 +827,12 @@ part0 ..$Long::random part1 ..$Long::random #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)))}))) + (for {@.old + ("jvm ladd" part0 part1) + + @.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" @@ -938,52 +946,59 @@ (_.context "byte" (array (/.newarray /instruction.t-byte) $Byte::random $Byte::literal [/.bastore /.baload $Byte::wrap] (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)))))}))))) + (for {@.old + (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) + + @.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) - (`` (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)))))}))))) + (for {@.old + (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) + + @.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) - (`` (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))))}))))) + (for {@.old + (|>> (:coerce java/lang/Integer) ("jvm ieq" (host.int-to-long expected))) + + @.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) - (`` (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))))}))))) + (for {@.old + (|>> (:coerce java/lang/Long) ("jvm leq" expected)) + + @.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) - (`` (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))))}))))) + (for {@.old + (|>> (:coerce java/lang/Float) ("jvm feq" expected)) + + @.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) - (`` (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))))}))))) + (for {@.old + (|>> (:coerce java/lang/Double) ("jvm deq" expected)) + + @.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) - (`` (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))))}))))) + (for {@.old + (|>> (:coerce java/lang/Character) ("jvm ceq" expected)) + + @.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@= (:coerce Text expected)))))) @@ -1013,10 +1028,11 @@ (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))))}))))) + (for {@.old + (|>> (:coerce <type>) (<old> expected)) + + @.jvm + (|>> (:coerce <type>) "jvm object cast" (<new> ("jvm object cast" (:coerce <type> expected))))})))) (def: conversion Test @@ -1043,18 +1059,20 @@ (_.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) - (`` (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)))))}))))) + (for {@.old + (|>> (:coerce java/lang/Byte) host.byte-to-long ("jvm leq" (host.byte-to-long expected))) + + @.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) (!::= java/lang/Character "jvm ceq" "jvm char ="))) (_.lift "I2S" (conversion ..$Integer::primitive ..$Short::primitive /.i2s (|>> host.int-to-short) (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)))))}))))))) + (for {@.old + (|>> (:coerce java/lang/Short) host.short-to-long ("jvm leq" (host.short-to-long expected))) + + @.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) int::=)) @@ -1126,15 +1144,16 @@ increment (:: @ map (|>> (n.% 100) /unsigned.u1 try.assume) random.nat) #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)))))})))]] + (for {@.old + ("jvm ladd" + (host.byte-to-long base) + (.int (/unsigned.value increment))) + + @.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) @@ -1385,10 +1404,11 @@ reference ..$Integer::random subject (|> ..$Integer::random (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))})) + #let [[lesser greater] (if (for {@.old + ("jvm ilt" reference subject) + + @.jvm + ("jvm int <" ("jvm object cast" subject) ("jvm object cast" reference))}) [reference subject] [subject reference]) int-comparison ($_ _.and |