aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/target/jvm/bytecode.lux356
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment.lux8
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux30
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/instruction.lux6
-rw-r--r--stdlib/source/lux/target/jvm/constant.lux6
-rw-r--r--stdlib/source/lux/target/jvm/constant/pool.lux74
-rw-r--r--stdlib/source/lux/test.lux8
-rw-r--r--stdlib/source/test/lux/target/jvm.lux540
8 files changed, 768 insertions, 260 deletions
diff --git a/stdlib/source/lux/target/jvm/bytecode.lux b/stdlib/source/lux/target/jvm/bytecode.lux
index 7dc974658..3adfabe67 100644
--- a/stdlib/source/lux/target/jvm/bytecode.lux
+++ b/stdlib/source/lux/target/jvm/bytecode.lux
@@ -1,11 +1,11 @@
(.module:
[lux (#- Type int)
- ["." host]
+ ["." host (#+ import:)]
[abstract
[monoid (#+ Monoid)]
["." monad (#+ Monad do)]]
[control
- [writer (#+ Writer)]
+ ["." writer (#+ Writer)]
["." state (#+ State')]
["." function]
["." try (#+ Try)]
@@ -18,7 +18,7 @@
[number
["n" nat]
["i" int]
- ["." i32]]
+ ["." i32 (#+ I32)]]
[collection
["." list ("#@." functor fold)]
["." dictionary (#+ Dictionary)]
@@ -31,7 +31,7 @@
["_" instruction (#+ Primitive-Array-Type Instruction Estimator) ("#@." monoid)]
["#." environment (#+ Environment)
[limit
- [registry (#+ Register)]]]
+ ["/." registry (#+ Register Registry)]]]
["/#" // #_
["#." index (#+ Index)]
[encoding
@@ -125,8 +125,12 @@
(def: #export monad
(Monad Bytecode)
- (:coerce (Monad Bytecode)
- (state.with try.monad)))
+ (<| (:coerce (Monad Bytecode))
+ (writer.with ..relative-monoid)
+ (: (Monad (State' Try [Pool Environment Tracker])))
+ state.with
+ (: (Monad Try))
+ try.monad))
(def: #export (resolve bytecode)
(All [a] (-> (Bytecode a) (Resource [Environment (Row Exception) Instruction a])))
@@ -140,14 +144,14 @@
(-> Estimator Address (Try Address))
(/address.move (estimator counter) counter))
-(def: (bytecode consumption production last-register [estimator bytecode] input)
- (All [a] (-> U2 U2 Register [Estimator (-> [a] Instruction)] [a] (Bytecode Any)))
+(def: (bytecode consumption production registry [estimator bytecode] input)
+ (All [a] (-> U2 U2 Registry [Estimator (-> [a] Instruction)] [a] (Bytecode Any)))
(function (_ [pool environment tracker])
(do try.monad
[environment' (|> environment
(/environment.consumes consumption)
(monad.bind @ (/environment.produces production))
- (monad.bind @ (/environment.has last-register)))
+ (monad.bind @ (/environment.has registry)))
program-counter' (step estimator (get@ #program-counter tracker))]
(wrap [[pool
environment'
@@ -168,66 +172,67 @@
)
(template [<name> <registry>]
- [(def: <name> Register (|> <registry> //unsigned.u1 try.assume))]
-
- [@0 0]
- [@1 1]
- [@2 2]
- [@3 3]
- [@4 4]
+ [(def: <name> Registry (|> <registry> //unsigned.u2 try.assume /registry.registry))]
+
+ [@_ 0]
+ [@0 1]
+ [@1 2]
+ [@2 3]
+ [@3 4]
+ [@4 5]
)
-(template [<name> <consumption> <production> <last-register> <instruction>]
+(template [<name> <consumption> <production> <registry> <instruction>]
[(def: #export <name>
(Bytecode Any)
(..bytecode <consumption>
<production>
- <last-register>
+ <registry>
<instruction>
[]))]
- [nop $0 $0 @0 _.nop]
+ [nop $0 $0 @_ _.nop]
- [aconst-null $0 $1 @0 _.aconst-null]
-
- [iconst-m1 $0 $1 @0 _.iconst-m1]
- [iconst-0 $0 $1 @0 _.iconst-0]
- [iconst-1 $0 $1 @0 _.iconst-1]
- [iconst-2 $0 $1 @0 _.iconst-2]
- [iconst-3 $0 $1 @0 _.iconst-3]
- [iconst-4 $0 $1 @0 _.iconst-4]
- [iconst-5 $0 $1 @0 _.iconst-5]
-
- [lconst-0 $0 $2 @0 _.lconst-0]
- [lconst-1 $0 $2 @0 _.lconst-1]
-
- [fconst-0 $0 $1 @0 _.fconst-0]
- [fconst-1 $0 $1 @0 _.fconst-1]
- [fconst-2 $0 $1 @0 _.fconst-2]
+ [aconst-null $0 $1 @_ _.aconst-null]
+
+ [iconst-m1 $0 $1 @_ _.iconst-m1]
+ [iconst-0 $0 $1 @_ _.iconst-0]
+ [iconst-1 $0 $1 @_ _.iconst-1]
+ [iconst-2 $0 $1 @_ _.iconst-2]
+ [iconst-3 $0 $1 @_ _.iconst-3]
+ [iconst-4 $0 $1 @_ _.iconst-4]
+ [iconst-5 $0 $1 @_ _.iconst-5]
+
+ [lconst-0 $0 $2 @_ _.lconst-0]
+ [lconst-1 $0 $2 @_ _.lconst-1]
+
+ [fconst-0 $0 $1 @_ _.fconst-0]
+ [fconst-1 $0 $1 @_ _.fconst-1]
+ [fconst-2 $0 $1 @_ _.fconst-2]
- [dconst-0 $0 $2 @0 _.dconst-0]
- [dconst-1 $0 $2 @0 _.dconst-1]
+ [dconst-0 $0 $2 @_ _.dconst-0]
+ [dconst-1 $0 $2 @_ _.dconst-1]
- [pop $1 $0 @0 _.pop]
- [pop2 $2 $0 @0 _.pop2]
+ [pop $1 $0 @_ _.pop]
+ [pop2 $2 $0 @_ _.pop2]
- [dup $1 $2 @0 _.dup]
- [dup-x1 $2 $3 @0 _.dup-x1]
- [dup-x2 $3 $4 @0 _.dup-x2]
- [dup2 $2 $4 @0 _.dup2]
- [dup2-x1 $3 $5 @0 _.dup2-x1]
- [dup2-x2 $4 $6 @0 _.dup2-x2]
+ [dup $1 $2 @_ _.dup]
+ [dup-x1 $2 $3 @_ _.dup-x1]
+ [dup-x2 $3 $4 @_ _.dup-x2]
+ [dup2 $2 $4 @_ _.dup2]
+ [dup2-x1 $3 $5 @_ _.dup2-x1]
+ [dup2-x2 $4 $6 @_ _.dup2-x2]
- [swap $2 $2 @0 _.swap]
+ [swap $2 $2 @_ _.swap]
- [iaload $2 $1 @0 _.iaload]
- [laload $2 $2 @0 _.laload]
- [faload $2 $1 @0 _.faload]
- [daload $2 $2 @0 _.daload]
- [aaload $2 $1 @0 _.aaload]
- [baload $2 $1 @0 _.baload]
- [caload $2 $1 @0 _.caload]
- [saload $2 $1 @0 _.saload]
+ [iaload $2 $1 @_ _.iaload]
+ [laload $2 $2 @_ _.laload]
+ [faload $2 $1 @_ _.faload]
+ [daload $2 $2 @_ _.daload]
+ [aaload $2 $1 @_ _.aaload]
+ [baload $2 $1 @_ _.baload]
+ [caload $2 $1 @_ _.caload]
+ [saload $2 $1 @_ _.saload]
[iload-0 $0 $1 @0 _.iload-0]
[iload-1 $0 $1 @1 _.iload-1]
@@ -254,14 +259,14 @@
[aload-2 $0 $1 @2 _.aload-2]
[aload-3 $0 $1 @3 _.aload-3]
- [iastore $3 $1 @0 _.iastore]
- [lastore $4 $1 @0 _.lastore]
- [fastore $3 $1 @0 _.fastore]
- [dastore $4 $1 @0 _.dastore]
- [aastore $3 $1 @0 _.aastore]
- [bastore $3 $1 @0 _.bastore]
- [castore $3 $1 @0 _.castore]
- [sastore $3 $1 @0 _.sastore]
+ [iastore $3 $1 @_ _.iastore]
+ [lastore $4 $1 @_ _.lastore]
+ [fastore $3 $1 @_ _.fastore]
+ [dastore $4 $1 @_ _.dastore]
+ [aastore $3 $1 @_ _.aastore]
+ [bastore $3 $1 @_ _.bastore]
+ [castore $3 $1 @_ _.castore]
+ [sastore $3 $1 @_ _.sastore]
[istore-0 $1 $0 @0 _.istore-0]
[istore-1 $1 $0 @1 _.istore-1]
@@ -288,91 +293,91 @@
[astore-2 $1 $0 @2 _.astore-2]
[astore-3 $1 $0 @3 _.astore-3]
- [iadd $2 $1 @0 _.iadd]
- [isub $2 $1 @0 _.isub]
- [imul $2 $1 @0 _.imul]
- [idiv $2 $1 @0 _.idiv]
- [irem $2 $1 @0 _.irem]
- [ineg $2 $1 @0 _.ineg]
- [ishl $2 $1 @0 _.ishl]
- [ishr $2 $1 @0 _.ishr]
- [iushr $2 $1 @0 _.iushr]
- [iand $2 $1 @0 _.iand]
- [ior $2 $1 @0 _.ior]
- [ixor $2 $1 @0 _.ixor]
-
- [ladd $4 $2 @0 _.ladd]
- [lsub $4 $2 @0 _.lsub]
- [lmul $4 $2 @0 _.lmul]
- [ldiv $4 $2 @0 _.ldiv]
- [lrem $4 $2 @0 _.lrem]
- [lneg $4 $2 @0 _.lneg]
- [land $4 $2 @0 _.land]
- [lor $4 $2 @0 _.lor]
- [lxor $4 $2 @0 _.lxor]
- [lshl $3 $2 @0 _.lshl]
- [lshr $3 $2 @0 _.lshr]
- [lushr $3 $2 @0 _.lushr]
+ [iadd $2 $1 @_ _.iadd]
+ [isub $2 $1 @_ _.isub]
+ [imul $2 $1 @_ _.imul]
+ [idiv $2 $1 @_ _.idiv]
+ [irem $2 $1 @_ _.irem]
+ [ineg $1 $1 @_ _.ineg]
+ [iand $2 $1 @_ _.iand]
+ [ior $2 $1 @_ _.ior]
+ [ixor $2 $1 @_ _.ixor]
+ [ishl $2 $1 @_ _.ishl]
+ [ishr $2 $1 @_ _.ishr]
+ [iushr $2 $1 @_ _.iushr]
+
+ [ladd $4 $2 @_ _.ladd]
+ [lsub $4 $2 @_ _.lsub]
+ [lmul $4 $2 @_ _.lmul]
+ [ldiv $4 $2 @_ _.ldiv]
+ [lrem $4 $2 @_ _.lrem]
+ [lneg $2 $2 @_ _.lneg]
+ [land $4 $2 @_ _.land]
+ [lor $4 $2 @_ _.lor]
+ [lxor $4 $2 @_ _.lxor]
+ [lshl $3 $2 @_ _.lshl]
+ [lshr $3 $2 @_ _.lshr]
+ [lushr $3 $2 @_ _.lushr]
- [fadd $2 $1 @0 _.fadd]
- [fsub $2 $1 @0 _.fsub]
- [fmul $2 $1 @0 _.fmul]
- [fdiv $2 $1 @0 _.fdiv]
- [frem $2 $1 @0 _.frem]
- [fneg $2 $1 @0 _.fneg]
+ [fadd $2 $1 @_ _.fadd]
+ [fsub $2 $1 @_ _.fsub]
+ [fmul $2 $1 @_ _.fmul]
+ [fdiv $2 $1 @_ _.fdiv]
+ [frem $2 $1 @_ _.frem]
+ [fneg $1 $1 @_ _.fneg]
- [dadd $4 $2 @0 _.dadd]
- [dsub $4 $2 @0 _.dsub]
- [dmul $4 $2 @0 _.dmul]
- [ddiv $4 $2 @0 _.ddiv]
- [drem $4 $2 @0 _.drem]
- [dneg $4 $2 @0 _.dneg]
-
- [l2i $2 $1 @0 _.l2i]
- [l2f $2 $1 @0 _.l2f]
- [l2d $2 $2 @0 _.l2d]
+ [dadd $4 $2 @_ _.dadd]
+ [dsub $4 $2 @_ _.dsub]
+ [dmul $4 $2 @_ _.dmul]
+ [ddiv $4 $2 @_ _.ddiv]
+ [drem $4 $2 @_ _.drem]
+ [dneg $2 $2 @_ _.dneg]
+
+ [l2i $2 $1 @_ _.l2i]
+ [l2f $2 $1 @_ _.l2f]
+ [l2d $2 $2 @_ _.l2d]
- [f2i $1 $1 @0 _.f2i]
- [f2l $1 $2 @0 _.f2l]
- [f2d $1 $2 @0 _.f2d]
+ [f2i $1 $1 @_ _.f2i]
+ [f2l $1 $2 @_ _.f2l]
+ [f2d $1 $2 @_ _.f2d]
- [d2i $2 $1 @0 _.d2i]
- [d2l $2 $2 @0 _.d2l]
- [d2f $2 $1 @0 _.d2f]
-
- [i2l $1 $2 @0 _.i2l]
- [i2f $1 $1 @0 _.i2f]
- [i2d $1 $2 @0 _.i2d]
- [i2b $1 $1 @0 _.i2b]
- [i2c $1 $1 @0 _.i2c]
- [i2s $1 $1 @0 _.i2s]
-
- [lcmp $4 $1 @0 _.lcmp]
+ [d2i $2 $1 @_ _.d2i]
+ [d2l $2 $2 @_ _.d2l]
+ [d2f $2 $1 @_ _.d2f]
+
+ [i2l $1 $2 @_ _.i2l]
+ [i2f $1 $1 @_ _.i2f]
+ [i2d $1 $2 @_ _.i2d]
+ [i2b $1 $1 @_ _.i2b]
+ [i2c $1 $1 @_ _.i2c]
+ [i2s $1 $1 @_ _.i2s]
+
+ [lcmp $4 $1 @_ _.lcmp]
- [fcmpl $2 $1 @0 _.fcmpl]
- [fcmpg $2 $1 @0 _.fcmpg]
+ [fcmpl $2 $1 @_ _.fcmpl]
+ [fcmpg $2 $1 @_ _.fcmpg]
- [dcmpl $4 $1 @0 _.dcmpl]
- [dcmpg $4 $1 @0 _.dcmpg]
+ [dcmpl $4 $1 @_ _.dcmpl]
+ [dcmpg $4 $1 @_ _.dcmpg]
- [ireturn $1 $0 @0 _.ireturn]
- [lreturn $2 $0 @0 _.lreturn]
- [freturn $1 $0 @0 _.freturn]
- [dreturn $2 $0 @0 _.dreturn]
- [areturn $1 $0 @0 _.areturn]
- [return $0 $0 @0 _.return]
+ [ireturn $1 $0 @_ _.ireturn]
+ [lreturn $2 $0 @_ _.lreturn]
+ [freturn $1 $0 @_ _.freturn]
+ [dreturn $2 $0 @_ _.dreturn]
+ [areturn $1 $0 @_ _.areturn]
+ [return $0 $0 @_ _.return]
- [arraylength $1 $1 @0 _.arraylength]
+ [arraylength $1 $1 @_ _.arraylength]
- [athrow $1 $0 @0 _.athrow]
+ [athrow $1 $0 @_ _.athrow]
- [monitorenter $1 $0 @0 _.monitorenter]
- [monitorexit $1 $0 @0 _.monitorexit]
+ [monitorenter $1 $0 @_ _.monitorenter]
+ [monitorexit $1 $0 @_ _.monitorexit]
)
(def: #export (bipush byte)
(-> U1 (Bytecode Any))
- (..bytecode $0 $1 @0 _.bipush [byte]))
+ (..bytecode $0 $1 @_ _.bipush [byte]))
(def: (lift resource)
(All [a]
@@ -391,24 +396,26 @@
[index (..lift (//constant/pool.string value))]
(case (|> index //index.value //unsigned.value //unsigned.u1)
(#try.Success index)
- (..bytecode $0 $1 @0 _.ldc [index])
+ (..bytecode $0 $1 @_ _.ldc [index])
(#try.Failure _)
- (..bytecode $0 $1 @0 _.ldc-w/string [index]))))
+ (..bytecode $0 $1 @_ _.ldc-w/string [index]))))
+
+(import: #long java/lang/Float)
-(template [<size> <name> <type> <constant> <ldc> <to-lux> <specializations>]
+(template [<size> <name> <type> <constructor> <constant> <ldc> <to-lux> <specializations>]
[(def: #export (<name> value)
(-> <type> (Bytecode Any))
- (case (|> value //constant.value <to-lux>)
+ (case (|> value <to-lux>)
(^template [<special> <instruction>]
- <special> (..bytecode $0 <size> @0 <instruction> []))
+ <special> (..bytecode $0 <size> @_ <instruction> []))
<specializations>
_ (do ..monad
- [index (..lift (<constant> value))]
- (..bytecode $0 <size> @0 <ldc> [index]))))]
+ [index (..lift (<constant> (<constructor> value)))]
+ (..bytecode $0 <size> @_ <ldc> [index]))))]
- [$1 int //constant.Integer //constant/pool.integer _.ldc-w/integer
+ [$1 int I32 //constant.integer //constant/pool.integer _.ldc-w/integer
(<| .int i32.i64)
([-1 _.iconst-m1]
[+0 _.iconst-0]
@@ -417,91 +424,91 @@
[+3 _.iconst-3]
[+4 _.iconst-4]
[+5 _.iconst-5])]
- [$2 long //constant.Long //constant/pool.long _.ldc2-w/long
+ [$2 long Int //constant.long //constant/pool.long _.ldc2-w/long
(<|)
([+0 _.lconst-0]
[+1 _.lconst-1])]
- [$1 float //constant.Float //constant/pool.float _.ldc-w/float
- (<| host.float-to-double)
+ [$1 float java/lang/Float //constant.float //constant/pool.float _.ldc-w/float
+ host.float-to-double
([+0.0 _.fconst-0]
[+1.0 _.fconst-1]
[+2.0 _.fconst-2])]
- [$2 double //constant.Double //constant/pool.double _.ldc2-w/double
+ [$2 double Frac //constant.double //constant/pool.double _.ldc2-w/double
(<|)
- ([+0.0 _.fconst-0]
- [+1.0 _.fconst-1])]
+ ([+0.0 _.dconst-0]
+ [+1.0 _.dconst-1])]
)
-(template [<size> <name> <general> <specials>]
+(template [<for> <size> <name> <general> <specials>]
[(def: #export (<name> local)
(-> Register (Bytecode Any))
(with-expansions [<specials>' (template.splice <specials>)]
(`` (case (//unsigned.value local)
- (~~ (template [<case> <instruction> <last-register>]
- [<case> (..bytecode $0 <size> <last-register> <instruction> [])]
+ (~~ (template [<case> <instruction> <registry>]
+ [<case> (..bytecode $0 <size> <registry> <instruction> [])]
<specials>'))
- _ (..bytecode $0 <size> local <general> [local])))))]
+ _ (..bytecode $0 <size> (<for> local) <general> [local])))))]
- [$1 iload _.iload
+ [/registry.for $1 iload _.iload
[[0 _.iload-0 @0]
[1 _.iload-1 @1]
[2 _.iload-2 @2]
[3 _.iload-3 @3]]]
- [$2 lload _.lload
+ [/registry.for-wide $2 lload _.lload
[[0 _.lload-0 @1]
[1 _.lload-1 @2]
[2 _.lload-2 @3]
[3 _.lload-3 @4]]]
- [$1 fload _.fload
+ [/registry.for $1 fload _.fload
[[0 _.fload-0 @0]
[1 _.fload-1 @1]
[2 _.fload-2 @2]
[3 _.fload-3 @3]]]
- [$2 dload _.dload
+ [/registry.for-wide $2 dload _.dload
[[0 _.dload-0 @1]
[1 _.dload-1 @2]
[2 _.dload-2 @3]
[3 _.dload-3 @4]]]
- [$1 aload _.aload
+ [/registry.for $1 aload _.aload
[[0 _.aload-0 @0]
[1 _.aload-1 @1]
[2 _.aload-2 @2]
[3 _.aload-3 @3]]]
)
-(template [<size> <name> <general> <specials>]
+(template [<for> <size> <name> <general> <specials>]
[(def: #export (<name> local)
(-> Register (Bytecode Any))
(with-expansions [<specials>' (template.splice <specials>)]
(`` (case (//unsigned.value local)
- (~~ (template [<case> <instruction> <last-register>]
- [<case> (..bytecode <size> $0 <last-register> <instruction> [])]
+ (~~ (template [<case> <instruction> <registry>]
+ [<case> (..bytecode <size> $0 <registry> <instruction> [])]
<specials>'))
- _ (..bytecode <size> $0 local <general> [local])))))]
+ _ (..bytecode <size> $0 (<for> local) <general> [local])))))]
- [$1 istore _.istore
+ [/registry.for $1 istore _.istore
[[0 _.istore-0 @0]
[1 _.istore-1 @1]
[2 _.istore-2 @2]
[3 _.istore-3 @3]]]
- [$2 lstore _.lstore
+ [/registry.for-wide $2 lstore _.lstore
[[0 _.lstore-0 @1]
[1 _.lstore-1 @2]
[2 _.lstore-2 @3]
[3 _.lstore-3 @4]]]
- [$1 fstore _.fstore
+ [/registry.for $1 fstore _.fstore
[[0 _.fstore-0 @0]
[1 _.fstore-1 @1]
[2 _.fstore-2 @2]
[3 _.fstore-3 @3]]]
- [$2 dstore _.dstore
+ [/registry.for-wide $2 dstore _.dstore
[[0 _.dstore-0 @1]
[1 _.dstore-1 @2]
[2 _.dstore-2 @3]
[3 _.dstore-3 @4]]]
- [$1 astore _.astore
+ [/registry.for $1 astore _.astore
[[0 _.astore-0 @0]
[1 _.astore-1 @1]
[2 _.astore-2 @2]
@@ -511,13 +518,16 @@
(template [<consumption> <production> <name> <instruction> <input>]
[(def: #export <name>
(-> <input> (Bytecode Any))
- (..bytecode <consumption> <production> @0 <instruction>))]
+ (..bytecode <consumption> <production> @_ <instruction>))]
- [$0 $0 ret _.ret Register]
[$1 $1 newarray _.newarray Primitive-Array-Type]
[$0 $1 sipush _.sipush U2]
)
+(def: #export (ret register)
+ (-> Register (Bytecode Any))
+ (..bytecode $0 $0 (/registry.for register) _.ret [register]))
+
(exception: #export (unknown-label {label Label})
(exception.report
["Label" (%.nat label)]))
@@ -713,7 +723,7 @@
(do ..monad
## TODO: Make sure it's impossible to have indexes greater than U2.
[index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
- (..bytecode <consumption> <production> @0 <instruction> [index])))]
+ (..bytecode <consumption> <production> @_ <instruction> [index])))]
[$0 $1 new Class _.new]
[$1 $1 anewarray Object _.anewarray]
@@ -723,13 +733,13 @@
(def: #export (iinc register increase)
(-> Register U1 (Bytecode Any))
- (..bytecode $0 $0 register _.iinc [register increase]))
+ (..bytecode $0 $0 (/registry.for register) _.iinc [register increase]))
(def: #export (multianewarray class dimensions)
(-> (Type Class) U1 (Bytecode Any))
(do ..monad
[index (..lift (//constant/pool.class (//name.internal (..reflection class))))]
- (..bytecode (//unsigned.lift/2 dimensions) $1 @0 _.multianewarray [index dimensions])))
+ (..bytecode (//unsigned.lift/2 dimensions) $1 @_ _.multianewarray [index dimensions])))
(def: (type-size type)
(-> (Type Return) Nat)
@@ -760,7 +770,7 @@
production (|> output ..type-size //unsigned.u1 try.assume)]]
(..bytecode (//unsigned.lift/2 consumption)
(//unsigned.lift/2 production)
- @0
+ @_
<instruction> [index consumption production]))))]
[#1 invokestatic _.invokestatic]
@@ -779,8 +789,8 @@
#//constant/pool.descriptor (type.descriptor type)})]
(if (or (is? type.long type)
(is? type.double type))
- (..bytecode <consumption> $2 @0 <2> [index])
- (..bytecode <consumption> $1 @0 <1> [index]))))]
+ (..bytecode <consumption> $2 @_ <2> [index])
+ (..bytecode <consumption> $1 @_ <1> [index]))))]
[$0 getstatic _.getstatic/1 _.getstatic/2]
[$1 putstatic _.putstatic/1 _.putstatic/2]
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment.lux b/stdlib/source/lux/target/jvm/bytecode/environment.lux
index 9056b0911..70db71c47 100644
--- a/stdlib/source/lux/target/jvm/bytecode/environment.lux
+++ b/stdlib/source/lux/target/jvm/bytecode/environment.lux
@@ -8,7 +8,7 @@
[/
["/." limit (#+ Limit)
["/." stack (#+ Stack)]
- ["/." registry (#+ Register)]]
+ ["/." registry (#+ Registry)]]
[///
[encoding
[unsigned (#+ U2)]]]])
@@ -57,7 +57,7 @@
(set@ #..stack current)
(set@ [#..limit #/limit.stack] limit))))))
-(def: #export (has register)
- (-> Register Condition)
- (|>> (update@ [#..limit #/limit.registry] (/registry.has register))
+(def: #export (has registry)
+ (-> Registry Condition)
+ (|>> (update@ [#..limit #/limit.registry] (/registry.has registry))
#try.Success))
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
index c04f6fa15..eb3820bfb 100644
--- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
+++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
@@ -1,9 +1,10 @@
(.module:
- [lux #*
+ [lux (#- for)
[abstract
["." equivalence (#+ Equivalence)]]
+ [control
+ ["." try]]
[data
- ["." maybe]
[format
[binary (#+ Writer)]]]
[type
@@ -19,9 +20,13 @@
U2
+ (def: #export registry
+ (-> U2 Registry)
+ (|>> :abstraction))
+
(def: #export empty
Registry
- (|> 0 /////unsigned.u2 maybe.assume :abstraction))
+ (|> 0 /////unsigned.u2 try.assume :abstraction))
(def: #export equivalence
(Equivalence Registry)
@@ -33,11 +38,24 @@
(Writer Registry)
(|>> :representation /////unsigned.writer/2))
- (def: #export (has register)
- (-> Register (-> Registry Registry))
+ (def: #export (has needed)
+ (-> Registry Registry Registry)
(|>> :representation
- (/////unsigned.max/2 (/////unsigned.lift/2 register))
+ (/////unsigned.max/2 (:representation needed))
:abstraction))
+
+ (template [<name> <extra>]
+ [(def: #export <name>
+ (-> Register Registry)
+ (let [extra (|> <extra> /////unsigned.u2 try.assume)]
+ (|>> /////unsigned.lift/2
+ (/////unsigned.+/2 extra)
+ try.assume
+ :abstraction)))]
+
+ [for 1]
+ [for-wide 2]
+ )
)
(def: #export length
diff --git a/stdlib/source/lux/target/jvm/bytecode/instruction.lux b/stdlib/source/lux/target/jvm/bytecode/instruction.lux
index 0a80b067c..2f26586c7 100644
--- a/stdlib/source/lux/target/jvm/bytecode/instruction.lux
+++ b/stdlib/source/lux/target/jvm/bytecode/instruction.lux
@@ -11,8 +11,8 @@
["." binary]
[number (#+ hex)
["n" nat]]
- [format
- [".F" binary (#+ Mutation Specification)]]
+ ["." format #_
+ ["#" binary (#+ Mutation Specification)]]
[collection
["." list]]]
[macro
@@ -52,7 +52,7 @@
(def: #export run
(-> Instruction Specification)
- (function.apply binaryF.no-op))
+ (function.apply format.no-op))
(type: Opcode Nat)
diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux
index 0cc7e16e1..91a72390a 100644
--- a/stdlib/source/lux/target/jvm/constant.lux
+++ b/stdlib/source/lux/target/jvm/constant.lux
@@ -40,6 +40,10 @@
{}
(Index UTF8)
+
+ (def: #export index
+ (-> Class (Index UTF8))
+ (|>> :representation))
(def: #export class
(-> (Index UTF8) Class)
@@ -48,7 +52,7 @@
(def: #export class-equivalence
(Equivalence Class)
(:: equivalence.contravariant map-1
- (|>> :representation)
+ ..index
//index.equivalence))
(def: class-writer
diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux
index a839a4a3e..b0d5c46fa 100644
--- a/stdlib/source/lux/target/jvm/constant/pool.lux
+++ b/stdlib/source/lux/target/jvm/constant/pool.lux
@@ -13,8 +13,7 @@
["n" nat]
["." int]
["." frac]]
- ["." text
- ["%" format (#+ format)]]
+ ["." text]
["." format #_
["#" binary (#+ Writer) ("specification@." monoid)]]
[collection
@@ -49,33 +48,34 @@
(state.with try.monad))
(template: (!add <tag> <equivalence> <value>)
- (function (_ [next pool])
- (with-expansions [<try-again> (as-is (recur (.inc idx)))]
- (loop [idx 0]
- (case (row.nth idx pool)
- (#.Some entry)
- (case entry
- [index (<tag> reference)]
- (if (:: <equivalence> = reference <value>)
- (#try.Success [[next pool]
- index])
+ (function (_ [current pool])
+ (let [<value>' <value>]
+ (with-expansions [<try-again> (as-is (recur (.inc idx)))]
+ (loop [idx 0]
+ (case (row.nth idx pool)
+ (#.Some entry)
+ (case entry
+ [index (<tag> reference)]
+ (if (:: <equivalence> = reference <value>')
+ (#try.Success [[current pool]
+ index])
+ <try-again>)
+
+ _
<try-again>)
- _
- <try-again>)
-
- #.None
- (let [new (<tag> <value>)]
- (do try.monad
- [@new (//unsigned.u2 (//.size new))
- next (: (Try Index)
- (|> next
- //index.value
- (//unsigned.+/2 @new)
- (:: @ map //index.index)))]
- (wrap [[next
- (row.add [next new] pool)]
- next]))))))))
+ #.None
+ (let [new (<tag> <value>')]
+ (do try.monad
+ [@new (//unsigned.u2 (//.size new))
+ next (: (Try Index)
+ (|> current
+ //index.value
+ (//unsigned.+/2 @new)
+ (:: @ map //index.index)))]
+ (wrap [[next
+ (row.add [current new] pool)]
+ current])))))))))
(template: (!index <index>)
(|> <index> //index.value //unsigned.value))
@@ -83,16 +83,16 @@
(type: (Adder of)
(-> of (Resource (Index of))))
-(template [<name> <type> <tag> <equivalence> <format>]
+(template [<name> <type> <tag> <equivalence>]
[(def: #export (<name> value)
(Adder <type>)
(!add <tag> <equivalence> value))]
- [integer Integer #//.Integer (//.value-equivalence i32.equivalence) (|>> //.value .nat %.nat)]
- [float Float #//.Float (//.value-equivalence //.float-equivalence) (|>> //.value host.float-to-double (:coerce Frac) %.frac)]
- [long Long #//.Long (//.value-equivalence int.equivalence) (|>> //.value %.int)]
- [double Double #//.Double (//.value-equivalence frac.equivalence) (|>> //.value %.frac)]
- [utf8 UTF8 #//.UTF8 text.equivalence %.text]
+ [integer Integer #//.Integer (//.value-equivalence i32.equivalence)]
+ [float Float #//.Float (//.value-equivalence //.float-equivalence)]
+ [long Long #//.Long (//.value-equivalence int.equivalence)]
+ [double Double #//.Double (//.value-equivalence frac.equivalence)]
+ [utf8 UTF8 #//.UTF8 text.equivalence]
)
(def: #export (string value)
@@ -126,9 +126,7 @@
(do ..monad
[@name (utf8 name)
@descriptor (..descriptor descriptor)]
- (!add #//.Name-And-Type //.name-and-type-equivalence
- {#//.name @name
- #//.descriptor @descriptor})))
+ (!add #//.Name-And-Type //.name-and-type-equivalence {#//.name @name #//.descriptor @descriptor})))
(template [<name> <tag> <of>]
[(def: #export (<name> class member)
@@ -136,9 +134,7 @@
(do ..monad
[@class (..class (//name.internal class))
@name-and-type (name-and-type member)]
- (!add <tag> //.reference-equivalence
- {#//.class @class
- #//.name-and-type @name-and-type})))]
+ (!add <tag> //.reference-equivalence {#//.class @class #//.name-and-type @name-and-type})))]
[field #//.Field Value]
[method #//.Method Method]
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index 9e1abb0fb..d36ff8059 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -19,7 +19,7 @@
["." instant]
["." duration]]
[math
- ["r" random ("#;." monad)]]])
+ ["r" random (#+ Random) ("#;." monad)]]])
(type: #export Counters
{#successes Nat
@@ -43,7 +43,7 @@
)
(type: #export Test
- (r.Random (Promise [Counters Text])))
+ (Random (Promise [Counters Text])))
(def: separator text.new-line)
@@ -93,6 +93,10 @@
(-> Text Bit Test)
(:: r.monad wrap (assert message condition)))
+(def: #export (lift message random)
+ (-> Text (Random Bit) Test)
+ (:: r.monad map (..assert message) random))
+
(def: pcg-32-magic-inc Nat 12345)
(type: #export Seed
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index a9eb21c22..b796a6993 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -1,8 +1,10 @@
(.module:
- [lux (#- Type type)
+ [lux (#- Type type primitive int)
["." host (#+ import:)]
- [abstract/monad (#+ do)]
+ [abstract
+ [monad (#+ do)]]
[control
+ ["." function]
["." io (#+ IO)]
["." try (#+ Try)]
[concurrency
@@ -12,11 +14,15 @@
[data
[binary (#+ Binary)]
[number
- ["i" int]]
- ["." text
+ ["." i32 (#+ I32)]
+ ["." i64]
+ ["n" nat]
+ ["i" int]
+ ["f" frac]]
+ ["." text ("#@." equivalence)
["%" format (#+ format)]]
- [format
- [".F" binary]]
+ ["." format #_
+ ["#" binary]]
[collection
["." array]
["." dictionary]
@@ -39,9 +45,12 @@
["#." constant
["#/." pool]]
[encoding
- ["#." name]]
- ["#." instruction
- ["#/." condition (#+ Environment)]]
+ ["#." name]
+ ["#." unsigned]]
+ ["#" bytecode (#+ Bytecode)
+ [environment
+ [limit
+ [registry (#+ Register)]]]]
["#." type (#+ Type)
[category (#+ Value)]]]})
@@ -72,8 +81,10 @@
(getClass [] (java/lang/Class java/lang/Object))
(toString [] java/lang/String))
-(import: #long java/lang/Long
- (#static TYPE (java/lang/Class java/lang/Long)))
+(import: #long java/lang/Integer)
+(import: #long java/lang/Long)
+(import: #long java/lang/Float)
+(import: #long java/lang/Double)
(def: class-name
(Random Text)
@@ -115,17 +126,480 @@
(host.array (java/lang/Class java/lang/Object) 0)
class))
-(def: $Long (/type.class "java.lang.Long" (list)))
(def: $Object (/type.class "java.lang.Object" (list)))
+(def: (bytecode test bytecode)
+ (-> (-> Any Bit) (Bytecode Any) (Random Bit))
+ (do random.monad
+ [class-name ..class-name
+ method-name (random.ascii/upper-alpha 10)
+ #let [inputsJT (list)
+ outputJT ..$Object
+ 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
+ [_ bytecode]
+ /.areturn)))
+ (row.row))
+ try.assume
+ (format.run /class.writer))
+ loader (/loader.memory (/loader.new-library []))]]
+ (wrap (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))]
+ (java/lang/reflect/Method::invoke (host.null) (host.array java/lang/Object 0) method))
+ (#try.Success actual)
+ (test actual)
+
+ (#try.Failure error)
+ false))))
+
+(def: $Integer
+ (/type.class "java.lang.Integer" (list)))
+(def: $Integer::wrap
+ (/.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))
+(def: $Integer::literal
+ (-> java/lang/Integer (Bytecode Any))
+ (|>> host.int-to-long .i64 i32.i32 /.int))
+
+(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.int)
+(def: $Long::literal /.long)
+
+(def: $Float (/type.class "java.lang.Float" (list)))
+(def: $Float::wrap (/.invokestatic ..$Float "valueOf" (/type.method [(list /type.float) ..$Float (list)])))
+(def: $Float::random
+ (Random java/lang/Float)
+ (:: random.monad map
+ (|>> (i.% +1024) i.frac host.double-to-float)
+ random.int))
+(def: $Float::literal /.float)
+
+(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: $String::random (random.unicode 10))
+(def: $String::literal /.string)
+(def: $String::wrap /.nop)
+
+(template: (int/2 <extension>)
+ (: (-> java/lang/Integer java/lang/Integer java/lang/Integer)
+ (function (_ parameter subject)
+ (<extension> subject 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))))
+ unary (: (-> (-> java/lang/Integer java/lang/Integer) (Bytecode Any) (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [subject ..$Integer::random]
+ (int (reference subject)
+ (do /.monad
+ [_ (..$Integer::literal subject)]
+ instruction)))))
+ binary (: (-> (-> java/lang/Integer java/lang/Integer java/lang/Integer)
+ (Bytecode Any)
+ (Random Bit))
+ (function (_ reference instruction)
+ (do random.monad
+ [parameter ..$Integer::random
+ subject ..$Integer::random]
+ (int (reference parameter subject)
+ (do /.monad
+ [_ (..$Integer::literal subject)
+ _ (..$Integer::literal parameter)]
+ instruction)))))
+ 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)
+ subject ..$Integer::random]
+ (int (reference parameter subject)
+ (do /.monad
+ [_ (..$Integer::literal subject)
+ _ (..$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 "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 "INEG" (unary (function (_ value)
+ ((int/2 "jvm isub") value (host.long-to-int +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)))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ (<| (_.context "bitwise")
+ bitwise)
+ )))
+
+(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)
+ (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)))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ (<| (_.context "bitwise")
+ bitwise)
+ )))
+
+(template: (float/2 <extension>)
+ (: (-> java/lang/Float java/lang/Float java/lang/Float)
+ (function (_ parameter subject)
+ (<extension> subject parameter))))
+
+(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)
+ (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)))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ )))
+
+(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)))]
+ ($_ _.and
+ (<| (_.context "literal")
+ literal)
+ (<| (_.context "arithmetic")
+ arithmetic)
+ )))
+
+(def: primitive
+ Test
+ ($_ _.and
+ (<| (_.context "int")
+ ..int)
+ (<| (_.context "long")
+ ..long)
+ (<| (_.context "float")
+ ..float)
+ (<| (_.context "double")
+ ..double)
+ ))
+
+(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]
+ (-> (Random a) (-> a (Bytecode Any)) (Bytecode Any)
+ [(-> Register (Bytecode Any)) (-> Register (Bytecode Any))]
+ (-> a (-> Any Bit))
+ (Random Bit)))
+ (function (_ random-value literal *wrap [store load] test)
+ (do random.monad
+ [expected random-value
+ register (:: @ map (|>> (n.% 128) /unsigned.u1 try.assume) random.nat)]
+ (<| (..bytecode (test expected))
+ (do /.monad
+ [_ (literal expected)
+ _ (store register)
+ _ (load register)]
+ *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)]
+ ($_ _.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/ILOAD"
+ (store-and-load ..$Integer::random ..$Integer::literal ..$Integer::wrap [/.istore /.iload]
+ (function (_ expected actual)
+ (|> actual (:coerce java/lang/Integer) ("jvm ieq" expected))))))))
+ (<| (_.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)]
+ ($_ _.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/LLOAD"
+ (store-and-load ..$Long::random ..$Long::literal ..$Long::wrap [/.lstore /.lload]
+ (function (_ expected actual)
+ (|> actual (:coerce java/lang/Long) ("jvm leq" expected))))))))
+ (<| (_.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)]
+ ($_ _.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/FLOAD"
+ (store-and-load ..$Float::random ..$Float::literal ..$Float::wrap [/.fstore /.fload]
+ (function (_ expected actual)
+ (|> actual (:coerce java/lang/Float) ("jvm feq" expected))))))))
+ (<| (_.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)]
+ ($_ _.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/DLOAD"
+ (store-and-load ..$Double::random ..$Double::literal ..$Double::wrap [/.dstore /.dload]
+ (function (_ expected actual)
+ (|> actual (:coerce java/lang/Double) ("jvm deq" expected))))))))
+ (<| (_.context "object")
+ (do random.monad
+ [## expected (random.text 10)
+ #let [test (function (_ expected actual)
+ (|> actual (:coerce Text) (text@= expected)))]]
+ ($_ _.and
+ (_.lift "ASTORE_0/ALOAD_0"
+ (store-and-load ..$String::random ..$String::literal ..$String::wrap [(function.constant /.astore-0) (function.constant /.aload-0)]
+ test))
+ (_.lift "ASTORE_1/ALOAD_1"
+ (store-and-load ..$String::random ..$String::literal ..$String::wrap [(function.constant /.astore-1) (function.constant /.aload-1)]
+ test))
+ (_.lift "ASTORE_2/ALOAD_2"
+ (store-and-load ..$String::random ..$String::literal ..$String::wrap [(function.constant /.astore-2) (function.constant /.aload-2)]
+ test))
+ (_.lift "ASTORE_3/ALOAD_3"
+ (store-and-load ..$String::random ..$String::literal ..$String::wrap [(function.constant /.astore-3) (function.constant /.aload-3)]
+ test))
+ (_.lift "ASTORE/ALOAD"
+ (store-and-load ..$String::random ..$String::literal ..$String::wrap [/.astore /.aload]
+ test)))))
+ )))
+
+(def: instruction
+ Test
+ ($_ _.and
+ ## (<| (_.lift "ACONST_NULL")
+ ## (..bytecode (function (_ value) true))
+ ## /.aconst-null)
+ (<| (_.context "primitive")
+ ..primitive)
+ (<| (_.context "registry")
+ ..registry)
+ ))
+
(def: method
Test
(do random.monad
[class-name ..class-name
method-name (random.ascii/upper-alpha 10)
- expected random.int
+ expected ..$Long::random
#let [inputsJT (list)
- outputJT $Object]]
+ outputJT ..$Object]]
(_.test "Can compile a method."
(let [bytecode (|> (/class.class /version.v6_0 /class.public
(/name.internal class-name)
@@ -138,13 +612,13 @@
method-name
(/type.method [inputsJT outputJT (list)])
(list)
- (do /instruction.monad
- [_ (/instruction.ldc/long (/constant.long expected))
- _ (/instruction.invokestatic $Long "valueOf"
- (/type.method [(list /type.long) $Long (list)]))]
- /instruction.areturn)))
+ (do /.monad
+ [_ (..$Long::literal expected)
+ _ ..$Long::wrap]
+ /.areturn)))
(row.row))
- (binaryF.run /class.writer))
+ try.assume
+ (format.run /class.writer))
loader (/loader.memory (/loader.new-library []))]
(case (do try.monad
[_ (/loader.define class-name bytecode loader)
@@ -164,16 +638,17 @@
[class-name ..class-name
[field0 type0] ..field
[field1 type1] ..field
- #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 type0 (row.row))
- (/field.field /field.public field1 type1 (row.row)))
- (list)
- (row.row))
- bytecode (binaryF.run /class.writer input)
+ #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."
@@ -183,7 +658,7 @@
(#try.Success definition)
true
- (#try.Failure _)
+ (#try.Failure error)
false))
)))
@@ -191,6 +666,7 @@
Test
(<| (_.context (%.name (name-of .._)))
($_ _.and
- ..class
+ ..instruction
..method
+ ..class
)))