aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/jvm/constant.lux9
-rw-r--r--stdlib/source/lux/target/jvm/constant/pool.lux91
-rw-r--r--stdlib/source/lux/target/jvm/program.lux12
-rw-r--r--stdlib/source/lux/target/jvm/program/instruction.lux4
-rw-r--r--stdlib/source/test/lux/target/jvm.lux153
5 files changed, 179 insertions, 90 deletions
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 <tag> <=> <value>)
- (function (_ pool)
- (with-expansions [<index> (as-is (//index.index (//unsigned.u2 (n/+ offset idx))))
- <try-again> (as-is (recur (.inc idx)))]
+ (function (_ [next pool])
+ (with-expansions [<try-again> (as-is (recur (.inc idx)))]
(loop [idx 0]
(case (row.nth idx pool)
(#.Some entry)
(case entry
- (<tag> reference)
+ [index (<tag> reference)]
(if (:: <=> = reference <value>)
- [pool
- <index>]
+ [[next pool]
+ index]
<try-again>)
_
<try-again>)
#.None
- [(row.add (<tag> <value>) pool)
- <index>])))))
+ (let [new (<tag> <value>)]
+ [[(|> next
+ //index.number
+ (//unsigned.u2/+ (//unsigned.u2 (//.size new)))
+ //index.index)
+ (row.add [next new] pool)]
+ next]))))))
(template: (!raw-index <index>)
- (|> <index> //index.number //unsigned.nat .nat))
+ (|> <index> //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 <tag> <index>)
- (function (_ pool)
- (case (row.nth (|> <index> !raw-index (n/- offset))
- pool)
- (#.Some entry)
- (case entry
- (<tag> value)
- [pool (#try.Success value)]
+ (with-expansions [<failure> (as-is [[next pool] (exception.throw ..invalid-index [<index>])])]
+ (function (_ [next pool])
+ (loop [idx 0]
+ (case (row.nth idx pool)
+ (#.Some [index entry])
+ (let [index' (!raw-index index)
+ <index>' (!raw-index <index>)]
+ (cond (n/< index' <index>')
+ (recur (inc idx))
- _
- [pool (exception.throw ..invalid-constant [<index> (name-of <tag>)])])
+ (n/= index' <index>')
+ (case entry
+ (<tag> value)
+ [[next pool] (#try.Success value)]
- #.None
- [pool (exception.throw ..invalid-index [<index> (row.size pool)])])))
+ _
+ [[next pool] (exception.throw ..invalid-constant [<index> (name-of <tag>)])])
+
+ ## (n/> index' <index>')
+ <failure>))
+
+ #.None
+ <failure>))
+ )))
(exception: #export (cannot-find {tag Name} {value Text})
(exception.report
@@ -94,24 +107,23 @@
["Value" value]))
(template: (!find <tag> <=> <%> <expected>)
- (function (_ pool)
- (with-expansions [<index> (as-is (//index.index (//unsigned.u2 (n/+ offset idx))))
- <try-again> (as-is (recur (.inc idx)))]
+ (function (_ [next pool])
+ (with-expansions [<try-again> (as-is (recur (.inc idx)))]
(loop [idx 0]
(case (row.nth idx pool)
- (#.Some entry)
+ (#.Some [index entry])
(case entry
(<tag> actual)
(if (:: <=> = actual <expected>)
- [pool
- (#try.Success <index>)]
+ [[next pool]
+ (#try.Success index)]
<try-again>)
_
<try-again>)
#.None
- [pool
+ [[next pool]
(exception.throw ..cannot-find [(name-of <tag>) (<%> <expected>)])])))))
(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 <static?> 0 1))))
- (descriptor-size output)))))]
+ (..nullary (<instruction>
+ index
+ (|> inputs
+ (list@map descriptor-size)
+ (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 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 []]
<fields>
["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
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 14:28:17 +0000