diff options
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/inst.lux | 17 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/host.jvm.lux | 72 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/generator/procedure/host.jvm.lux | 100 |
3 files changed, 182 insertions, 7 deletions
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index efc66f130..d5df6a9f7 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -28,6 +28,7 @@ L2D L2F L2I) <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE T_BYTE T_SHORT T_INT T_LONG) + <class> (declare CHECKCAST NEW INSTANCEOF) <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2 POP POP2 SWAP) @@ -51,6 +52,7 @@ FALOAD FASTORE DALOAD DASTORE CALOAD CASTORE) + <concurrency> (declare MONITORENTER MONITOREXIT) <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)] (host;import org.objectweb.asm.Opcodes (#static NOP int) @@ -58,8 +60,7 @@ <conversion> <primitive> - (#static CHECKCAST int) - (#static NEW int) + <class> <stack> <jump> @@ -84,6 +85,8 @@ (#static ATHROW int) + <concurrency> + <return> )) @@ -196,6 +199,9 @@ ## Exceptions [ATHROW] + ## Concurrency + [MONITORENTER] [MONITOREXIT] + ## Return [RETURN] [IRETURN] [LRETURN] [DRETURN] [ARETURN] ) @@ -232,9 +238,10 @@ (do-to visitor (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))] - [CHECKCAST Opcodes.CHECKCAST] - [NEW Opcodes.NEW] - [ANEWARRAY Opcodes.ANEWARRAY] + [CHECKCAST Opcodes.CHECKCAST] + [NEW Opcodes.NEW] + [INSTANCEOF Opcodes.INSTANCEOF] + [ANEWARRAY Opcodes.ANEWARRAY] ) (def: #export (NEWARRAY type) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index 128e8b517..a6e14659d 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -357,6 +357,77 @@ (@;install "write" array//write) ))) +(def: (object//null _) + @;Nullary + $i;NULL) + +(def: (object//null? objectI) + @;Unary + (<| $i;with-label (function [@then]) + $i;with-label (function [@end]) + (|>. objectI + ($i;IFNULL @then) + ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list))) + ($i;GOTO @end) + ($i;label @then) + ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list))) + ($i;label @end)))) + +(def: (object//synchronized [monitorI exprI]) + @;Binary + (|>. monitorI + $i;DUP + $i;MONITORENTER + exprI + $i;SWAP + $i;MONITOREXIT)) + +(def: (object//throw exceptionI) + @;Unary + (|>. exceptionI + $i;ATHROW)) + +(def: (object//class proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class))) + (do macro;Monad<Lux> + [] + (wrap (|>. ($i;string class) + ($i;INVOKESTATIC "java.lang.Class" "forName" + ($t;method (list ($t;class "java.lang.String" (list))) + (#;Some ($t;class "java.lang.Class" (list))) + (list)) + false)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: (object//instance? proc generate inputs) + (-> Text @;Proc) + (case inputs + (^ (list (#ls;Text class) objectS)) + (do macro;Monad<Lux> + [objectI (generate objectS)] + (wrap (|>. objectI + ($i;INSTANCEOF class) + ($i;wrap #$;Boolean)))) + + _ + (&;fail (format "Wrong syntax for '" proc "'.")))) + +(def: object-procs + @;Bundle + (<| (@;prefix "object") + (|> (dict;new text;Hash<Text>) + (@;install "null" (@;nullary object//null)) + (@;install "null?" (@;unary object//null?)) + (@;install "synchronized" (@;binary object//synchronized)) + (@;install "throw" (@;unary object//throw)) + (@;install "class" object//class) + (@;install "instance?" object//instance?) + ))) + (def: #export procedures @;Bundle (<| (@;prefix "jvm") @@ -368,4 +439,5 @@ (dict;merge double-procs) (dict;merge char-procs) (dict;merge array-procs) + (dict;merge object-procs) ))) diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index 6371286a6..a33b6d52f 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -3,11 +3,14 @@ (lux [io] (control [monad #+ do] pipe) - (data ["R" result] + (data [maybe] + ["R" result] [bit] [bool "bool/" Eq<Bool>] [number "int/" Number<Int>] - text/format) + [text "text/" Eq<Text>] + text/format + (coll [list])) ["r" math/random "r/" Monad<Random>] [macro #+ Monad<Lux>] [host] @@ -341,3 +344,96 @@ (#R;Error error) false))) ))) + +(host;import java.lang.Class + (getName [] String)) + +(def: classes + (List Text) + (list "java.lang.Object" "java.lang.Class" + "java.lang.String" "java.lang.Number")) + +(def: instances + (List [Text (r;Random ls;Synthesis)]) + (let [gen-boolean (|> r;bool (:: r;Functor<Random> map (|>. #ls;Bool))) + gen-integer (|> r;int (:: r;Functor<Random> map (|>. #ls;Int))) + gen-double (|> r;frac (:: r;Functor<Random> map (|>. #ls;Frac))) + gen-string (|> (r;text +5) (:: r;Functor<Random> map (|>. #ls;Text)))] + (list ["java.lang.Boolean" gen-boolean] + ["java.lang.Long" gen-integer] + ["java.lang.Double" gen-double] + ["java.lang.String" gen-string] + ["java.lang.Object" (r;either (r;either gen-boolean + gen-integer) + (r;either gen-double + gen-string))]))) + +(context: "Object." + [#let [num-classes (list;size classes)] + #let [num-instances (list;size instances)] + class-idx (|> r;nat (:: @ map (n.% num-classes))) + instance-idx (|> r;nat (:: @ map (n.% num-instances))) + #let [class (maybe;assume (list;nth class-idx classes)) + [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances))] + sample r;int + monitor r;int + instance instance-gen] + ($_ seq + (test "jvm object null" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (|> (#ls;Procedure "jvm object null" (list)) + (list) (#ls;Procedure "jvm object null?")))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (:! Bool outputG) + + (#R;Error error) + false))) + (test "jvm object null?" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (|> (#ls;Int sample) + (list) (#ls;Procedure "jvm object null?")))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (not (:! Bool outputG)) + + (#R;Error error) + false))) + (test "jvm object synchronized" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (#ls;Procedure "jvm object synchronized" + (list (#ls;Int monitor) + (#ls;Int sample))))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (i.= sample (:! Int outputG)) + + (#R;Error error) + false))) + (test "jvm object throw" + false) + (test "jvm object class" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (|> outputG (:! Class) (Class.getName []) (text/= class)) + + (#R;Error error) + false))) + (test "jvm object instance?" + (|> (do macro;Monad<Lux> + [sampleI (@;generate (#ls;Procedure "jvm object instance?" (list (#ls;Text instance-class) + instance)))] + (@eval;eval sampleI)) + (macro;run (init-compiler [])) + (case> (#R;Success outputG) + (:! Bool outputG) + + (#R;Error error) + false))) + )) |