diff options
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode.lux | 356 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode/environment.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux | 30 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/bytecode/instruction.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/constant.lux | 6 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/constant/pool.lux | 74 | ||||
| -rw-r--r-- | stdlib/source/lux/test.lux | 8 | ||||
| -rw-r--r-- | stdlib/source/test/lux/target/jvm.lux | 540 |
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 ))) |