diff options
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/jvm.lux | 265 |
2 files changed, 141 insertions, 135 deletions
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux index 4175cc572..7db2d8e4b 100644 --- a/stdlib/source/lux/target/jvm/bytecode.lux +++ b/stdlib/source/lux/target/jvm/bytecode.lux @@ -795,10 +795,17 @@ (-> Register U1 (Bytecode Any)) (..bytecode $0 $0 (/registry.for register) _.iinc [register increase])) +(exception: #export (multiarray-cannot-be-zero-dimensional {class (Type Object)}) + (exception.report ["Class" (..reflection class)])) + (def: #export (multianewarray class dimensions) - (-> (Type Class) U1 (Bytecode Any)) + (-> (Type Object) U1 (Bytecode Any)) (do ..monad - [index (..lift (//constant/pool.class (//name.internal (..reflection class))))] + [_ (: (Bytecode Any) + (case (|> dimensions //unsigned.value) + 0 (..throw ..multiarray-cannot-be-zero-dimensional [class]) + _ (wrap []))) + index (..lift (//constant/pool.class (//name.internal (..reflection class))))] (..bytecode (//unsigned.lift/2 dimensions) $1 @_ _.multianewarray [index dimensions]))) (def: (type-size type) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index f0e6b2b91..e6d48aa21 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -2,7 +2,7 @@ [lux (#- Type type primitive int) ["." host (#+ import:)] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." function] ["." io (#+ IO)] @@ -58,7 +58,7 @@ [limit [registry (#+ Register)]]]] ["#." type (#+ Type) - ["." category (#+ Value)]]]}) + ["." category (#+ Value Object)]]]}) ## (def: (write-class! name bytecode) ## (-> Text Binary (IO Text)) @@ -111,30 +111,6 @@ /name.external-separator package /name.external-separator name)))) -(def: type - (Random (Type Value)) - (random.rec - (function (_ type) - ($_ random.either - (random@wrap /type.boolean) - (random@wrap /type.byte) - (random@wrap /type.short) - (random@wrap /type.int) - (random@wrap /type.long) - (random@wrap /type.float) - (random@wrap /type.double) - (random@wrap /type.char) - (random@map (function (_ name) (/type.class name (list))) ..class-name) - (random@map /type.array type) - )))) - -(def: field - (Random [Text (Type Value)]) - ($_ random.and - (random.ascii/lower-alpha 10) - ..type - )) - (def: (get-method name class) (-> Text (java/lang/Class java/lang/Object) java/lang/reflect/Method) (java/lang/Class::getDeclaredMethod name @@ -716,43 +692,113 @@ _ /.dup _ /.monitorexit _ (/.instanceof ..$String)] ..$Boolean::wrap)) - (<| (_.lift "INVOKESTATIC") - (do random.monad - [expected ..$Double::random]) - (..bytecode (|>> (:coerce java/lang/Double) ("jvm deq" expected))) - (do /.monad - [_ (/.double 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)))) - (do /.monad - [_ (/.double 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))) - (do /.monad - [_ (/.new ..$Double) - _ /.dup - _ (/.double 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)))) - (do /.monad - [_ (/.string subject) - _ (/.invokeinterface (/type.class "java.lang.CharSequence" (list)) "length" (/type.method [(list) /type.int (list)])) - _ /.i2l] - ..$Long::wrap)) ))) +(def: method + Test + ($_ _.and + (<| (_.lift "INVOKESTATIC") + (do random.monad + [expected ..$Double::random]) + (..bytecode (|>> (:coerce java/lang/Double) ("jvm deq" expected))) + (do /.monad + [_ (/.double 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)))) + (do /.monad + [_ (/.double 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))) + (do /.monad + [_ (/.new ..$Double) + _ /.dup + _ (/.double 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)))) + (do /.monad + [_ (/.string subject) + _ (/.invokeinterface (/type.class "java.lang.CharSequence" (list)) "length" (/type.method [(list) /type.int (list)])) + _ /.i2l] + ..$Long::wrap)) + )) + +(def: field + Test + (do random.monad + [class-name ..class-name + part0 ..$Long::random + part1 ..$Long::random + #let [expected (i.+ part0 part1) + $Self (/type.class class-name (list)) + class-field "instances" + object-field "value" + constructor "<init>" + constructor::type (/type.method [(list /type.long) /type.void (list)]) + static-method "procedure" + bytecode (|> (/class.class /version.v6_0 /class.public + (/name.internal class-name) + (/name.internal "java.lang.Object") + (list) + (list (/field.field /field.static class-field /type.long (row.row)) + (/field.field /field.public object-field /type.long (row.row))) + (list (/method.method /method.private + constructor + constructor::type + (list) + (do /.monad + [_ /.aload-0 + _ (/.invokespecial ..$Object "<init>" (/type.method [(list) /type.void (list)])) + _ (..$Long::literal part0) + _ (/.putstatic $Self class-field /type.long) + _ /.aload-0 + _ /.lload-1 + _ (/.putfield $Self object-field /type.long)] + /.return)) + (/method.method ($_ /modifier@compose + /method.public + /method.static) + static-method + (/type.method [(list) ..$Long (list)]) + (list) + (do /.monad + [_ (/.new $Self) + _ /.dup + _ (..$Long::literal part1) + _ (/.invokespecial $Self "<init>" constructor::type) + _ (/.getfield $Self object-field /type.long) + _ (/.getstatic $Self class-field /type.long) + _ /.ladd + _ ..$Long::wrap] + /.areturn))) + (row.row)) + try.assume + (format.run /class.writer)) + loader (/loader.memory (/loader.new-library []))]] + (_.test "PUTSTATIC & PUTFIELD & GETFIELD & GETSTATIC" + (case (do try.monad + [_ (/loader.define class-name bytecode loader) + class (io.run (/loader.load class-name loader)) + method (host.try (get-method static-method class)) + 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) + + (#try.Failure error) + false)))) + (def: array Test (let [!length (: (-> Nat (Bytecode Any)) @@ -829,6 +875,27 @@ (_.context "object" (array (/.anewarray ..$String) $String::random $String::literal [/.aastore /.aaload /.nop] (function (_ expected) (|>> (:coerce Text) (text@= expected))))) + (<| (_.context "multi") + (do random.monad + [#let [size (:: @ map (|>> (n.% 10) (n.+ 1)) + random.nat)] + dimensions size + sizesH size + sizesT (monad.seq @ (list.repeat (dec dimensions) size)) + #let [type (loop [dimensions dimensions + type (: (Type Object) + ..$Object)] + (case dimensions + 0 type + _ (recur (dec dimensions) (/type.array type))))]] + (<| (_.lift "MULTIANEWARRAY") + (..bytecode (|>> (:coerce java/lang/Long) ("jvm leq" (.int sizesH)))) + (do /.monad + [_ (monad.map @ (|>> host.long-to-int ..$Integer::literal) + (#.Cons sizesH sizesT)) + _ (/.multianewarray type (|> dimensions /unsigned.u1 try.assume)) + _ ?length] + $Long::wrap)))) ))) (def: conversion @@ -892,6 +959,10 @@ ..primitive) (<| (_.context "object") ..object) + (<| (_.context "method") + ..method) + (<| (_.context "field") + ..field) (<| (_.context "array") ..array) (<| (_.context "conversion") @@ -1370,81 +1441,9 @@ ..code) )) -(def: method - Test - (do random.monad - [class-name ..class-name - method-name (random.ascii/upper-alpha 10) - expected ..$Long::random - #let [inputsJT (list) - outputJT ..$Object]] - (_.test "Can compile a method." - (let [bytecode (|> (/class.class /version.v6_0 /class.public - (/name.internal class-name) - (/name.internal "java.lang.Object") - (list) - (list) - (list (/method.method ($_ /modifier@compose - /method.public - /method.static) - method-name - (/type.method [inputsJT outputJT (list)]) - (list) - (do /.monad - [_ (..$Long::literal expected) - _ ..$Long::wrap] - /.areturn))) - (row.row)) - try.assume - (format.run /class.writer)) - loader (/loader.memory (/loader.new-library []))] - (case (do try.monad - [_ (/loader.define class-name bytecode loader) - class (io.run (/loader.load class-name loader)) - method (host.try (get-method method-name class)) - 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) - - (#try.Failure error) - false))))) - -(def: class - Test - (do random.monad - [class-name ..class-name - [field0 type0] ..field - [field1 type1] ..field - #let [bytecode (|> (/class.class /version.v6_0 /class.public - (/name.internal class-name) - (/name.internal "java.lang.Object") - (list (/name.internal "java.io.Serializable") - (/name.internal "java.lang.Runnable")) - (list (/field.field /field.public field0 type0 (row.row)) - (/field.field /field.public field1 type1 (row.row))) - (list) - (row.row)) - try.assume - (format.run /class.writer)) - loader (/loader.memory (/loader.new-library []))]] - ($_ _.and - (_.test "Can generate a class." - (case (do try.monad - [_ (/loader.define class-name bytecode loader)] - (io.run (/loader.load class-name loader))) - (#try.Success definition) - true - - (#try.Failure error) - false)) - ))) - (def: #export test Test (<| (_.context (%.name (name-of .._))) ($_ _.and ..instruction - ..method - ..class ))) |