From e3559192310c7db980eabe87b8a588f9bf653e44 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 6 Jul 2019 22:32:40 -0400 Subject: Got long and double constants to work. --- stdlib/source/lux/target/jvm/constant.lux | 9 ++ stdlib/source/lux/target/jvm/constant/pool.lux | 91 ++++++------ stdlib/source/lux/target/jvm/program.lux | 12 +- .../source/lux/target/jvm/program/instruction.lux | 4 +- stdlib/source/test/lux/target/jvm.lux | 153 +++++++++++++++------ 5 files changed, 179 insertions(+), 90 deletions(-) (limited to 'stdlib') diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux index c157d4abb..0f4aca590 100644 --- a/stdlib/source/lux/target/jvm/constant.lux +++ b/stdlib/source/lux/target/jvm/constant.lux @@ -127,6 +127,15 @@ (#Interface-Method (Reference //descriptor.Method)) (#Name-And-Type (Name-And-Type Any))) +(def: #export (size constant) + (-> Constant Nat) + (case constant + (^or (#Long _) (#Double _)) + 2 + + _ + 1)) + (def: #export equivalence (Equivalence Constant) ## TODO: Delete the explicit "structure" and use the combinator diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux index 062f7553b..a03bba71b 100644 --- a/stdlib/source/lux/target/jvm/constant/pool.lux +++ b/stdlib/source/lux/target/jvm/constant/pool.lux @@ -29,43 +29,45 @@ ["#." index (#+ Index)] ["#." descriptor (#+ Field Method Descriptor)]]]) -(def: offset 1) - -(type: #export Pool (Row Constant)) +(type: #export Pool [Index (Row [Index Constant])]) (def: #export equivalence (Equivalence Pool) - (row.equivalence //.equivalence)) + (equivalence.product //index.equivalence + (row.equivalence (equivalence.product //index.equivalence + //.equivalence)))) (template: (!add <=> ) - (function (_ pool) - (with-expansions [ (as-is (//index.index (//unsigned.u2 (n/+ offset idx)))) - (as-is (recur (.inc idx)))] + (function (_ [next pool]) + (with-expansions [ (as-is (recur (.inc idx)))] (loop [idx 0] (case (row.nth idx pool) (#.Some entry) (case entry - ( reference) + [index ( reference)] (if (:: <=> = reference ) - [pool - ] + [[next pool] + index] ) _ ) #.None - [(row.add ( ) pool) - ]))))) + (let [new ( )] + [[(|> next + //index.number + (//unsigned.u2/+ (//unsigned.u2 (//.size new))) + //index.index) + (row.add [next new] pool)] + next])))))) (template: (!raw-index ) - (|> //index.number //unsigned.nat .nat)) + (|> //index.number //unsigned.nat)) -(exception: #export (invalid-index {index (Index Any)} - {maximum Nat}) +(exception: #export (invalid-index {index (Index Any)}) (exception.report - ["Index" (|> index !raw-index %.nat)] - ["Maximum" (%.nat maximum)])) + ["Index" (|> index !raw-index %.nat)])) (exception: #export (invalid-constant {index (Index Any)} {tag Name}) @@ -74,19 +76,30 @@ ["Expected tag" (%.name tag)])) (template: (!fetch ) - (function (_ pool) - (case (row.nth (|> !raw-index (n/- offset)) - pool) - (#.Some entry) - (case entry - ( value) - [pool (#try.Success value)] + (with-expansions [ (as-is [[next pool] (exception.throw ..invalid-index [])])] + (function (_ [next pool]) + (loop [idx 0] + (case (row.nth idx pool) + (#.Some [index entry]) + (let [index' (!raw-index index) + ' (!raw-index )] + (cond (n/< index' ') + (recur (inc idx)) - _ - [pool (exception.throw ..invalid-constant [ (name-of )])]) + (n/= index' ') + (case entry + ( value) + [[next pool] (#try.Success value)] - #.None - [pool (exception.throw ..invalid-index [ (row.size pool)])]))) + _ + [[next pool] (exception.throw ..invalid-constant [ (name-of )])]) + + ## (n/> index' ') + )) + + #.None + )) + ))) (exception: #export (cannot-find {tag Name} {value Text}) (exception.report @@ -94,24 +107,23 @@ ["Value" value])) (template: (!find <=> <%> ) - (function (_ pool) - (with-expansions [ (as-is (//index.index (//unsigned.u2 (n/+ offset idx)))) - (as-is (recur (.inc idx)))] + (function (_ [next pool]) + (with-expansions [ (as-is (recur (.inc idx)))] (loop [idx 0] (case (row.nth idx pool) - (#.Some entry) + (#.Some [index entry]) (case entry ( actual) (if (:: <=> = actual ) - [pool - (#try.Success )] + [[next pool] + (#try.Success index)] ) _ ) #.None - [pool + [[next pool] (exception.throw ..cannot-find [(name-of ) (<%> )])]))))) (type: (Adder of) @@ -193,12 +205,13 @@ (def: #export writer (Writer Pool) - (function (_ pool) - (row@fold (function (_ post pre) + (function (_ [next pool]) + (row@fold (function (_ [_index post] pre) (specification@compose pre (//.writer post))) - (binaryF.bits/16 (n/+ ..offset (row.size pool))) + (binaryF.bits/16 (!raw-index next)) pool))) (def: #export empty Pool - row.empty) + [(|> 1 //unsigned.u2 //index.index) + row.empty]) diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux index 85f21a152..aeb3e0b0a 100644 --- a/stdlib/source/lux/target/jvm/program.lux +++ b/stdlib/source/lux/target/jvm/program.lux @@ -484,12 +484,12 @@ (//constant/pool.method class) {#//constant/pool.name method #//constant/pool.descriptor (//descriptor.method inputs output)})] - (wrap (/instruction.invokestatic - index - (|> inputs - (list@map descriptor-size) - (list@fold //unsigned.u1/+ (//unsigned.u1 (if 0 1)))) - (descriptor-size output)))))] + (..nullary ( + index + (|> inputs + (list@map descriptor-size) + (list@fold //unsigned.u1/+ (//unsigned.u1 (if 0 1)))) + (descriptor-size output)))))] [#1 invokestatic /instruction.invokestatic] [#0 invokevirtual /instruction.invokevirtual] diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux index 07f769082..4f9c43f56 100644 --- a/stdlib/source/lux/target/jvm/program/instruction.lux +++ b/stdlib/source/lux/target/jvm/program/instruction.lux @@ -449,8 +449,8 @@ ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.number index)] 0 1 []] ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.number index)] 0 1 []] ["13" ldc-w/string [[index (Index ///constant.String)]] [(///index.number index)] 0 1 []] - ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 1 []] - ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 1 []] + ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 2 []] + ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 2 []] ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []] ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []] diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index f044b74d0..8f97645b4 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -1,11 +1,10 @@ (.module: [lux #* + ["." host (#+ import:)] [abstract/monad (#+ do)] [control ["." io (#+ IO)] ["." try (#+ Try)] - [parser - ["<2>" binary]] [concurrency ["." atom]] [security @@ -17,26 +16,32 @@ [format [".F" binary]] [collection + ["." array] ["." dictionary] ["." row]]] [world ["." file (#+ File)]] [math - ["r" random (#+ Random) ("#@." monad)]] + ["." random (#+ Random) ("#@." monad)]] ["_" test (#+ Test)]] {1 ["." / #_ - ["#." program] - ["#." loader (#+ Library)] ["#." version] ["#." descriptor (#+ Descriptor Value)] + ["#." modifier ("#@." monoid)] ["#." field] + ["#." method] ["#." class] + ["#." attribute + ["#/." code]] + ["#." constant + ["#/." pool]] [encoding ["#." name]] - [modifier - ["#.M" inner]]]}) + ["#." program + ["#/." condition (#+ Environment)] + ["#/." instruction]]]}) ## (def: (write-class! name bytecode) ## (-> Text Binary (IO Text)) @@ -53,64 +58,123 @@ ## (#try.Failure error) ## error))))) +(import: #long java/lang/String) + +(import: #long java/lang/reflect/Method + (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)) + +(import: #long (java/lang/Class c) + (getDeclaredMethod [java/lang/String [(java/lang/Class java/lang/Object)]] java/lang/reflect/Method)) + +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object)) + (toString [] java/lang/String)) + +(import: #long java/lang/Long + (#static TYPE (java/lang/Class java/lang/Long))) + (def: descriptor (Random (Descriptor (Value Any))) - (r.rec + (random.rec (function (_ descriptor) - ($_ r.either - (r@wrap /descriptor.boolean) - (r@wrap /descriptor.byte) - (r@wrap /descriptor.short) - (r@wrap /descriptor.int) - (r@wrap /descriptor.long) - (r@wrap /descriptor.float) - (r@wrap /descriptor.double) - (r@wrap /descriptor.char) - (r@map (|>> (text.join-with /name.external-separator) - /name.internal - /descriptor.object) - (r.list 3 (r.ascii/upper-alpha 10))) - (r@map /descriptor.array descriptor) + ($_ random.either + (random@wrap /descriptor.boolean) + (random@wrap /descriptor.byte) + (random@wrap /descriptor.short) + (random@wrap /descriptor.int) + (random@wrap /descriptor.long) + (random@wrap /descriptor.float) + (random@wrap /descriptor.double) + (random@wrap /descriptor.char) + (random@map (|>> (text.join-with /name.external-separator) /descriptor.object) + (random.list 3 (random.ascii/upper-alpha 10))) + (random@map /descriptor.array descriptor) )))) (def: field (Random [Text (Descriptor (Value Any))]) - ($_ r.and - (r.ascii/lower-alpha 10) + ($_ random.and + (random.ascii/lower-alpha 10) ..descriptor )) +(def: class-name + (Random Text) + (do random.monad + [super-package (random.ascii/lower-alpha 10) + package (random.ascii/lower-alpha 10) + name (random.ascii/upper-alpha 10)] + (wrap (format super-package "." package "." name)))) + +(def: (get-method name class) + (-> Text (java/lang/Class java/lang/Object) java/lang/reflect/Method) + (java/lang/Class::getDeclaredMethod name + (host.array (java/lang/Class java/lang/Object) 0) + class)) + +(def: method + Test + (do random.monad + [class-name ..class-name + method-name (random.ascii/upper-alpha 10) + expected random.int + #let [inputsJT (list) + outputJT (/descriptor.object "java.lang.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 + (/descriptor.method inputsJT outputJT) + (list) + (do /program.monad + [_ (/program.ldc/long (/constant.long expected)) + _ (/program.invokestatic "java.lang.Long" "valueOf" + (list /descriptor.long) + (/descriptor.object "java.lang.Long"))] + /program.areturn))) + (row.row)) + (binaryF.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 r.monad - [_ (wrap []) - super-package (r.ascii/lower-alpha 10) - package (r.ascii/lower-alpha 10) - name (r.ascii/upper-alpha 10) + (do random.monad + [class-name ..class-name [field0 descriptor0] ..field [field1 descriptor1] ..field - #let [full-name (format super-package "." package "." name) - input (/class.class /version.v6_0 /class.public - (/name.internal full-name) + #let [input (/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 descriptor0 (row.row)) (/field.field /field.public field1 descriptor1 (row.row))) - (row.row) + (list) (row.row)) bytecode (binaryF.run /class.writer input) loader (/loader.memory (/loader.new-library []))]] ($_ _.and - (_.test "Can read a generated class." - (case (<2>.run /class.parser bytecode) - (#try.Success output) - (:: /class.equivalence = input output) - - (#try.Failure _) - false)) (_.test "Can generate a class." - (case (/loader.define full-name bytecode loader) + (case (do try.monad + [_ (/loader.define class-name bytecode loader)] + (io.run (/loader.load class-name loader))) (#try.Success definition) true @@ -120,5 +184,8 @@ (def: #export test Test - (<| (_.context "Class") - ..class)) + (<| (_.context (%.name (name-of .._))) + ($_ _.and + ..class + ..method + ))) -- cgit v1.2.3