aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/generator/host/jvm/inst.lux17
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux72
-rw-r--r--new-luxc/test/test/luxc/generator/procedure/host.jvm.lux100
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)))
+ ))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 19:54:17 +0000