aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/jvm/type/alias.lux1
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux1085
4 files changed, 1088 insertions, 4 deletions
diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux
index 49b4c0297..d21cbc1c2 100644
--- a/stdlib/source/lux/target/jvm/type/alias.lux
+++ b/stdlib/source/lux/target/jvm/type/alias.lux
@@ -12,7 +12,6 @@
["." text
["%" format (#+ format)]]
[collection
- [array (#+ Array)]
["." dictionary (#+ Dictionary)]]]]
["." // (#+ Type)
[category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
index 8202fd101..c4481998e 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- Type primitive type char int)
+ [lux (#- Type Module primitive type char int)
["." host (#+ import:)]
["." macro]
[abstract
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux
index b7cc9c9fe..d436d1974 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux
@@ -5,7 +5,7 @@
["." dictionary]]]]
["." / #_
["#." common]
- ## ["#." host]
+ ["#." host]
[//
[runtime (#+ Bundle)]]])
@@ -13,5 +13,5 @@
Bundle
($_ dictionary.merge
/common.bundle
- ## /host.bundle
+ /host.bundle
))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux
new file mode 100644
index 000000000..7b14d2c07
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux
@@ -0,0 +1,1085 @@
+(.module:
+ [lux (#- Type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." try]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<t>" text]
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#@." equivalence)]
+ [number
+ ["." i32]]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]
+ ["." row]]
+ ["." format #_
+ ["#" binary]]]
+ [target
+ [jvm
+ ["." version]
+ ["." modifier ("#@." monoid)]
+ ["." method (#+ Method)]
+ ["." class (#+ Class)]
+ [constant
+ [pool (#+ Resource)]]
+ [encoding
+ ["." name]]
+ ["_" bytecode (#+ Label Bytecode) ("#@." monad)
+ ["__" instruction (#+ Primitive-Array-Type)]]
+ ["." type (#+ Type Typed Argument)
+ ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)]
+ ["." box]
+ ["." reflection]
+ ["." signature]
+ ["." parser]]]]]
+ ["." // #_
+ [common (#+ custom)]
+ ["/#" //
+ [runtime (#+ Operation Bundle Handler)]
+ ["#." reference]
+ [function
+ [field
+ [variable
+ ["." foreign]]]]
+ ["//#" ///
+ ["." generation
+ [extension (#+ Nullary Unary Binary Trinary Variadic
+ nullary unary binary trinary variadic)]]
+ [extension
+ ["#." bundle]
+ [analysis
+ ["/" jvm]]]
+ ["/#" //
+ [analysis (#+ Environment)]
+ ["#." reference (#+ Variable)]
+ ["#." synthesis (#+ Synthesis Path %synthesis)]]]]])
+
+(template [<name> <0> <1>]
+ [(def: <name>
+ (Bytecode Any)
+ ($_ _.compose
+ <0>
+ <1>))]
+
+ [l2s _.l2i _.i2s]
+ [l2b _.l2i _.i2b]
+ [l2c _.l2i _.i2c]
+ )
+
+(template [<conversion> <name>]
+ [(def: (<name> inputG)
+ (Unary (Bytecode Any))
+ (if (is? _.nop <conversion>)
+ inputG
+ ($_ _.compose
+ inputG
+ <conversion>)))]
+
+ [_.d2f conversion::double-to-float]
+ [_.d2i conversion::double-to-int]
+ [_.d2l conversion::double-to-long]
+ [_.f2d conversion::float-to-double]
+ [_.f2i conversion::float-to-int]
+ [_.f2l conversion::float-to-long]
+ [_.i2b conversion::int-to-byte]
+ [_.i2c conversion::int-to-char]
+ [_.i2d conversion::int-to-double]
+ [_.i2f conversion::int-to-float]
+ [_.i2l conversion::int-to-long]
+ [_.i2s conversion::int-to-short]
+ [_.l2d conversion::long-to-double]
+ [_.l2f conversion::long-to-float]
+ [_.l2i conversion::long-to-int]
+ [..l2s conversion::long-to-short]
+ [..l2b conversion::long-to-byte]
+ [..l2c conversion::long-to-char]
+ [_.i2b conversion::char-to-byte]
+ [_.i2s conversion::char-to-short]
+ [_.nop conversion::char-to-int]
+ [_.i2l conversion::char-to-long]
+ [_.i2l conversion::byte-to-long]
+ [_.i2l conversion::short-to-long]
+ )
+
+(def: bundle::conversion
+ Bundle
+ (<| (/////bundle.prefix "conversion")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "double-to-float" (unary conversion::double-to-float))
+ (/////bundle.install "double-to-int" (unary conversion::double-to-int))
+ (/////bundle.install "double-to-long" (unary conversion::double-to-long))
+ (/////bundle.install "float-to-double" (unary conversion::float-to-double))
+ (/////bundle.install "float-to-int" (unary conversion::float-to-int))
+ (/////bundle.install "float-to-long" (unary conversion::float-to-long))
+ (/////bundle.install "int-to-byte" (unary conversion::int-to-byte))
+ (/////bundle.install "int-to-char" (unary conversion::int-to-char))
+ (/////bundle.install "int-to-double" (unary conversion::int-to-double))
+ (/////bundle.install "int-to-float" (unary conversion::int-to-float))
+ (/////bundle.install "int-to-long" (unary conversion::int-to-long))
+ (/////bundle.install "int-to-short" (unary conversion::int-to-short))
+ (/////bundle.install "long-to-double" (unary conversion::long-to-double))
+ (/////bundle.install "long-to-float" (unary conversion::long-to-float))
+ (/////bundle.install "long-to-int" (unary conversion::long-to-int))
+ (/////bundle.install "long-to-short" (unary conversion::long-to-short))
+ (/////bundle.install "long-to-byte" (unary conversion::long-to-byte))
+ (/////bundle.install "long-to-char" (unary conversion::long-to-char))
+ (/////bundle.install "char-to-byte" (unary conversion::char-to-byte))
+ (/////bundle.install "char-to-short" (unary conversion::char-to-short))
+ (/////bundle.install "char-to-int" (unary conversion::char-to-int))
+ (/////bundle.install "char-to-long" (unary conversion::char-to-long))
+ (/////bundle.install "byte-to-long" (unary conversion::byte-to-long))
+ (/////bundle.install "short-to-long" (unary conversion::short-to-long))
+ )))
+
+(template [<name> <op>]
+ [(def: (<name> [xG yG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ xG
+ yG
+ <op>))]
+
+ [int::+ _.iadd]
+ [int::- _.isub]
+ [int::* _.imul]
+ [int::/ _.idiv]
+ [int::% _.irem]
+ [int::and _.iand]
+ [int::or _.ior]
+ [int::xor _.ixor]
+ [int::shl _.ishl]
+ [int::shr _.ishr]
+ [int::ushr _.iushr]
+
+ [long::+ _.ladd]
+ [long::- _.lsub]
+ [long::* _.lmul]
+ [long::/ _.ldiv]
+ [long::% _.lrem]
+ [long::and _.land]
+ [long::or _.lor]
+ [long::xor _.lxor]
+ [long::shl _.lshl]
+ [long::shr _.lshr]
+ [long::ushr _.lushr]
+
+ [float::+ _.fadd]
+ [float::- _.fsub]
+ [float::* _.fmul]
+ [float::/ _.fdiv]
+ [float::% _.frem]
+
+ [double::+ _.dadd]
+ [double::- _.dsub]
+ [double::* _.dmul]
+ [double::/ _.ddiv]
+ [double::% _.drem]
+ )
+
+(def: $Boolean (type.class box.boolean (list)))
+(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean))
+(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean))
+
+(template [<name> <op>]
+ [(def: (<name> [xG yG])
+ (Binary (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ xG
+ yG
+ (<op> @then)
+ falseG
+ (_.goto @end)
+ (_.set-label @then)
+ trueG
+ (_.set-label @end))))]
+
+ [int::= _.if-icmpeq]
+ [int::< _.if-icmplt]
+
+ [char::= _.if-icmpeq]
+ [char::< _.if-icmplt]
+ )
+
+(template [<name> <op> <reference>]
+ [(def: (<name> [xG yG])
+ (Binary (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ xG
+ yG
+ <op>
+ (_.int (i32.i32 (.i64 <reference>)))
+ (_.if-icmpeq @then)
+ falseG
+ (_.goto @end)
+ (_.set-label @then)
+ trueG
+ (_.set-label @end))))]
+
+ [long::= _.lcmp +0]
+ [long::< _.lcmp -1]
+
+ [float::= _.fcmpg +0]
+ [float::< _.fcmpg -1]
+
+ [double::= _.dcmpg +0]
+ [double::< _.dcmpg -1]
+ )
+
+(def: bundle::int
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.int))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary int::+))
+ (/////bundle.install "-" (binary int::-))
+ (/////bundle.install "*" (binary int::*))
+ (/////bundle.install "/" (binary int::/))
+ (/////bundle.install "%" (binary int::%))
+ (/////bundle.install "=" (binary int::=))
+ (/////bundle.install "<" (binary int::<))
+ (/////bundle.install "and" (binary int::and))
+ (/////bundle.install "or" (binary int::or))
+ (/////bundle.install "xor" (binary int::xor))
+ (/////bundle.install "shl" (binary int::shl))
+ (/////bundle.install "shr" (binary int::shr))
+ (/////bundle.install "ushr" (binary int::ushr))
+ )))
+
+(def: bundle::long
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.long))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary long::+))
+ (/////bundle.install "-" (binary long::-))
+ (/////bundle.install "*" (binary long::*))
+ (/////bundle.install "/" (binary long::/))
+ (/////bundle.install "%" (binary long::%))
+ (/////bundle.install "=" (binary long::=))
+ (/////bundle.install "<" (binary long::<))
+ (/////bundle.install "and" (binary long::and))
+ (/////bundle.install "or" (binary long::or))
+ (/////bundle.install "xor" (binary long::xor))
+ (/////bundle.install "shl" (binary long::shl))
+ (/////bundle.install "shr" (binary long::shr))
+ (/////bundle.install "ushr" (binary long::ushr))
+ )))
+
+(def: bundle::float
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.float))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary float::+))
+ (/////bundle.install "-" (binary float::-))
+ (/////bundle.install "*" (binary float::*))
+ (/////bundle.install "/" (binary float::/))
+ (/////bundle.install "%" (binary float::%))
+ (/////bundle.install "=" (binary float::=))
+ (/////bundle.install "<" (binary float::<))
+ )))
+
+(def: bundle::double
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.double))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "+" (binary double::+))
+ (/////bundle.install "-" (binary double::-))
+ (/////bundle.install "*" (binary double::*))
+ (/////bundle.install "/" (binary double::/))
+ (/////bundle.install "%" (binary double::%))
+ (/////bundle.install "=" (binary double::=))
+ (/////bundle.install "<" (binary double::<))
+ )))
+
+(def: bundle::char
+ Bundle
+ (<| (/////bundle.prefix (reflection.reflection reflection.char))
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "=" (binary char::=))
+ (/////bundle.install "<" (binary char::<))
+ )))
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<t>.embed <parser> <s>.text))]
+
+ [var Var parser.var]
+ [class category.Class parser.class]
+ [object Object parser.object]
+ [value Value parser.value]
+ [return Return parser.return]
+ )
+
+(exception: #export (not-an-object-array {arrayJT (Type Array)})
+ (exception.report
+ ["JVM Type" (|> arrayJT type.signature signature.signature)]))
+
+(def: #export object-array
+ (Parser (Type Object))
+ (do <>.monad
+ [arrayJT (<t>.embed parser.array <s>.text)]
+ (case (parser.array? arrayJT)
+ (#.Some elementJT)
+ (case (parser.object? elementJT)
+ (#.Some elementJT)
+ (wrap elementJT)
+
+ #.None
+ (<>.fail (exception.construct ..not-an-object-array arrayJT)))
+
+ #.None
+ (undefined))))
+
+(def: (primitive-array-length-handler jvm-primitive)
+ (-> (Type Primitive) Handler)
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate arrayS)
+ (do /////.monad
+ [arrayG (generate arrayS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array jvm-primitive))
+ _.arraylength))))]))
+
+(def: array::length::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any)
+ (function (_ extension-name generate [elementJT arrayS])
+ (do /////.monad
+ [arrayG (generate arrayS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array elementJT))
+ _.arraylength))))]))
+
+(def: (new-primitive-array-handler jvm-primitive)
+ (-> Primitive-Array-Type Handler)
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate [lengthS])
+ (do /////.monad
+ [lengthG (generate lengthS)]
+ (wrap ($_ _.compose
+ lengthG
+ (_.newarray jvm-primitive)))))]))
+
+(def: array::new::object
+ Handler
+ (..custom
+ [($_ <>.and ..object <s>.any)
+ (function (_ extension-name generate [objectJT lengthS])
+ (do /////.monad
+ [lengthG (generate lengthS)]
+ (wrap ($_ _.compose
+ lengthG
+ (_.anewarray objectJT)))))]))
+
+(def: (read-primitive-array-handler jvm-primitive loadG)
+ (-> (Type Primitive) (Bytecode Any) Handler)
+ (..custom
+ [($_ <>.and <s>.any <s>.any)
+ (function (_ extension-name generate [idxS arrayS])
+ (do /////.monad
+ [arrayG (generate arrayS)
+ idxG (generate idxS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array jvm-primitive))
+ idxG
+ loadG))))]))
+
+(def: array::read::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any)
+ (function (_ extension-name generate [elementJT idxS arrayS])
+ (do /////.monad
+ [arrayG (generate arrayS)
+ idxG (generate idxS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array elementJT))
+ idxG
+ _.aaload))))]))
+
+(def: (write-primitive-array-handler jvm-primitive storeG)
+ (-> (Type Primitive) (Bytecode Any) Handler)
+ (..custom
+ [($_ <>.and <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate [idxS valueS arrayS])
+ (do /////.monad
+ [arrayG (generate arrayS)
+ idxG (generate idxS)
+ valueG (generate valueS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array jvm-primitive))
+ _.dup
+ idxG
+ valueG
+ storeG))))]))
+
+(def: array::write::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate [elementJT idxS valueS arrayS])
+ (do /////.monad
+ [arrayG (generate arrayS)
+ idxG (generate idxS)
+ valueG (generate valueS)]
+ (wrap ($_ _.compose
+ arrayG
+ (_.checkcast (type.array elementJT))
+ _.dup
+ idxG
+ valueG
+ _.aastore))))]))
+
+(def: bundle::array
+ Bundle
+ (<| (/////bundle.prefix "array")
+ (|> /////bundle.empty
+ (dictionary.merge (<| (/////bundle.prefix "length")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean))
+ (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte))
+ (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short))
+ (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int))
+ (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long))
+ (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float))
+ (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double))
+ (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char))
+ (/////bundle.install "object" array::length::object))))
+ (dictionary.merge (<| (/////bundle.prefix "new")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean))
+ (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte))
+ (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short))
+ (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int))
+ (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long))
+ (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float))
+ (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double))
+ (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char))
+ (/////bundle.install "object" array::new::object))))
+ (dictionary.merge (<| (/////bundle.prefix "read")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload))
+ (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload))
+ (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload))
+ (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload))
+ (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload))
+ (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload))
+ (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload))
+ (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload))
+ (/////bundle.install "object" array::read::object))))
+ (dictionary.merge (<| (/////bundle.prefix "write")
+ (|> /////bundle.empty
+ (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore))
+ (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore))
+ (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore))
+ (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore))
+ (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore))
+ (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore))
+ (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore))
+ (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore))
+ (/////bundle.install "object" array::write::object))))
+ )))
+
+(def: (object::null _)
+ (Nullary (Bytecode Any))
+ _.aconst-null)
+
+(def: (object::null? objectG)
+ (Unary (Bytecode Any))
+ (do _.monad
+ [@then _.new-label
+ @end _.new-label]
+ ($_ _.compose
+ objectG
+ (_.ifnull @then)
+ ..falseG
+ (_.goto @end)
+ (_.set-label @then)
+ ..trueG
+ (_.set-label @end))))
+
+(def: (object::synchronized [monitorG exprG])
+ (Binary (Bytecode Any))
+ ($_ _.compose
+ monitorG
+ _.dup
+ _.monitorenter
+ exprG
+ _.swap
+ _.monitorexit))
+
+(def: (object::throw exceptionG)
+ (Unary (Bytecode Any))
+ ($_ _.compose
+ exceptionG
+ _.athrow))
+
+(def: $Class (type.class "java.lang.Class" (list)))
+(def: $String (type.class "java.lang.String" (list)))
+
+(def: object::class
+ Handler
+ (..custom
+ [<s>.text
+ (function (_ extension-name generate [class])
+ (do /////.monad
+ []
+ (wrap ($_ _.compose
+ (_.string class)
+ (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))]))
+
+(def: object::instance?
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension-name generate [class objectS])
+ (do /////.monad
+ [objectG (generate objectS)]
+ (wrap ($_ _.compose
+ objectG
+ (_.instanceof (type.class class (list)))
+ (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))]))
+
+(def: reflection
+ (All [category]
+ (-> (Type (<| Return' Value' category)) Text))
+ (|>> type.reflection reflection.reflection))
+
+(def: object::cast
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate [from to valueS])
+ (do /////.monad
+ [valueG (generate valueS)]
+ (wrap (`` (cond (~~ (template [<object> <type> <unwrap>]
+ [(and (text@= (..reflection <type>)
+ from)
+ (text@= <object>
+ to))
+ (let [$<object> (type.class <object> (list))]
+ ($_ _.compose
+ valueG
+ (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)]))))
+
+ (and (text@= <object>
+ from)
+ (text@= (..reflection <type>)
+ to))
+ (let [$<object> (type.class <object> (list))]
+ ($_ _.compose
+ valueG
+ (_.checkcast $<object>)
+ (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))]
+
+ [box.boolean type.boolean "booleanValue"]
+ [box.byte type.byte "byteValue"]
+ [box.short type.short "shortValue"]
+ [box.int type.int "intValue"]
+ [box.long type.long "longValue"]
+ [box.float type.float "floatValue"]
+ [box.double type.double "doubleValue"]
+ [box.char type.char "charValue"]))
+ ## else
+ valueG)))))]))
+
+(def: bundle::object
+ Bundle
+ (<| (/////bundle.prefix "object")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "null" (nullary object::null))
+ (/////bundle.install "null?" (unary object::null?))
+ (/////bundle.install "synchronized" (binary object::synchronized))
+ (/////bundle.install "throw" (unary object::throw))
+ (/////bundle.install "class" object::class)
+ (/////bundle.install "instance?" object::instance?)
+ (/////bundle.install "cast" object::cast)
+ )))
+
+(def: primitives
+ (Dictionary Text (Type Primitive))
+ (|> (list [(reflection.reflection reflection.boolean) type.boolean]
+ [(reflection.reflection reflection.byte) type.byte]
+ [(reflection.reflection reflection.short) type.short]
+ [(reflection.reflection reflection.int) type.int]
+ [(reflection.reflection reflection.long) type.long]
+ [(reflection.reflection reflection.float) type.float]
+ [(reflection.reflection reflection.double) type.double]
+ [(reflection.reflection reflection.char) type.char])
+ (dictionary.from-list text.hash)))
+
+(def: get::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text)
+ (function (_ extension-name generate [class field unboxed])
+ (do /////.monad
+ [#let [$class (type.class class (list))]]
+ (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (wrap (_.getstatic $class field primitive))
+
+ #.None
+ (wrap (_.getstatic $class field (type.class unboxed (list)))))))]))
+
+(def: unitG (_.string //////synthesis.unit))
+
+(def: put::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate [class field unboxed valueS])
+ (do /////.monad
+ [valueG (generate valueS)
+ #let [$class (type.class class (list))]]
+ (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (wrap ($_ _.compose
+ valueG
+ (_.putstatic $class field primitive)
+ ..unitG))
+
+ #.None
+ (wrap ($_ _.compose
+ valueG
+ (_.checkcast $class)
+ (_.putstatic $class field $class)
+ ..unitG)))))]))
+
+(def: get::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate [class field unboxed objectS])
+ (do /////.monad
+ [objectG (generate objectS)
+ #let [$class (type.class class (list))
+ getG (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (_.getfield $class field primitive)
+
+ #.None
+ (_.getfield $class field (type.class unboxed (list))))]]
+ (wrap ($_ _.compose
+ objectG
+ (_.checkcast $class)
+ getG))))]))
+
+(def: put::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
+ (function (_ extension-name generate [class field unboxed valueS objectS])
+ (do /////.monad
+ [valueG (generate valueS)
+ objectG (generate objectS)
+ #let [$class (type.class class (list))
+ putG (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (_.putfield $class field primitive)
+
+ #.None
+ (let [$unboxed (type.class unboxed (list))]
+ ($_ _.compose
+ (_.checkcast $unboxed)
+ (_.putfield $class field $unboxed))))]]
+ (wrap ($_ _.compose
+ objectG
+ (_.checkcast $class)
+ _.dup
+ valueG
+ putG))))]))
+
+(type: Input (Typed Synthesis))
+
+(def: input
+ (Parser Input)
+ (<s>.tuple (<>.and ..value <s>.any)))
+
+(def: (generate-input generate [valueT valueS])
+ (-> (-> Synthesis (Operation (Bytecode Any))) Input
+ (Operation (Typed (Bytecode Any))))
+ (do /////.monad
+ [valueG (generate valueS)]
+ (case (type.primitive? valueT)
+ (#.Right valueT)
+ (wrap [valueT valueG])
+
+ (#.Left valueT)
+ (wrap [valueT ($_ _.compose
+ valueG
+ (_.checkcast valueT))]))))
+
+(def: (prepare-output outputT)
+ (-> (Type Return) (Bytecode Any))
+ (case (type.void? outputT)
+ (#.Right outputT)
+ ..unitG
+
+ (#.Left outputT)
+ (:: _.monad wrap [])))
+
+(def: invoke::static
+ Handler
+ (..custom
+ [($_ <>.and ..class <s>.text ..return (<>.some ..input))
+ (function (_ extension-name generate [class method outputT inputsTS])
+ (do /////.monad
+ [inputsTG (monad.map @ (generate-input generate) inputsTS)]
+ (wrap ($_ _.compose
+ (monad.map _.monad product.right inputsTG)
+ (_.invokestatic class method (type.method [(list@map product.left inputsTG) outputT (list)]))
+ (prepare-output outputT)))))]))
+
+(template [<name> <invoke>]
+ [(def: <name>
+ Handler
+ (..custom
+ [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
+ (function (_ extension-name generate [class method outputT objectS inputsTS])
+ (do /////.monad
+ [objectG (generate objectS)
+ inputsTG (monad.map @ (generate-input generate) inputsTS)]
+ (wrap ($_ _.compose
+ objectG
+ (_.checkcast class)
+ (monad.map _.monad product.right inputsTG)
+ (<invoke> class method (type.method [(list@map product.left inputsTG) outputT (list)]))
+ (prepare-output outputT)))))]))]
+
+ [invoke::virtual _.invokevirtual]
+ [invoke::special _.invokespecial]
+ [invoke::interface _.invokeinterface]
+ )
+
+(def: invoke::constructor
+ Handler
+ (..custom
+ [($_ <>.and ..class (<>.some ..input))
+ (function (_ extension-name generate [class inputsTS])
+ (do /////.monad
+ [inputsTG (monad.map @ (generate-input generate) inputsTS)]
+ (wrap ($_ _.compose
+ (_.new class)
+ _.dup
+ (monad.map _.monad product.right inputsTG)
+ (_.invokespecial class "<init>" (type.method [(list@map product.left inputsTG) type.void (list)]))))))]))
+
+(def: bundle::member
+ Bundle
+ (<| (/////bundle.prefix "member")
+ (|> (: Bundle /////bundle.empty)
+ (dictionary.merge (<| (/////bundle.prefix "get")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "static" get::static)
+ (/////bundle.install "virtual" get::virtual))))
+ (dictionary.merge (<| (/////bundle.prefix "put")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "static" put::static)
+ (/////bundle.install "virtual" put::virtual))))
+ (dictionary.merge (<| (/////bundle.prefix "invoke")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "static" invoke::static)
+ (/////bundle.install "virtual" invoke::virtual)
+ (/////bundle.install "special" invoke::special)
+ (/////bundle.install "interface" invoke::interface)
+ (/////bundle.install "constructor" invoke::constructor))))
+ )))
+
+(def: annotation-parameter
+ (Parser (/.Annotation-Parameter Synthesis))
+ (<s>.tuple (<>.and <s>.text <s>.any)))
+
+(def: annotation
+ (Parser (/.Annotation Synthesis))
+ (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
+
+(def: argument
+ (Parser Argument)
+ (<s>.tuple (<>.and <s>.text ..value)))
+
+(def: overriden-method-definition
+ (Parser [Environment (/.Overriden-Method Synthesis)])
+ (<s>.tuple (do <>.monad
+ [_ (<s>.text! /.overriden-tag)
+ ownerT ..class
+ name <s>.text
+ strict-fp? <s>.bit
+ annotations (<s>.tuple (<>.some ..annotation))
+ vars (<s>.tuple (<>.some ..var))
+ self-name <s>.text
+ arguments (<s>.tuple (<>.some ..argument))
+ returnT ..return
+ exceptionsT (<s>.tuple (<>.some ..class))
+ [environment body] (<s>.function 1
+ (<s>.tuple <s>.any))]
+ (wrap [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]]))))
+
+(def: (normalize-path normalize)
+ (-> (-> Synthesis Synthesis)
+ (-> Path Path))
+ (function (recur path)
+ (case path
+ (^ (//////synthesis.path/then bodyS))
+ (//////synthesis.path/then (normalize bodyS))
+
+ (^template [<tag>]
+ (^ (<tag> leftP rightP))
+ (<tag> (recur leftP) (recur rightP)))
+ ([#//////synthesis.Alt]
+ [#//////synthesis.Seq])
+
+ (^template [<tag>]
+ (^ (<tag> value))
+ path)
+ ([#//////synthesis.Pop]
+ [#//////synthesis.Test]
+ [#//////synthesis.Bind]
+ [#//////synthesis.Access]))))
+
+(def: (normalize-method-body mapping)
+ (-> (Dictionary Variable Variable) Synthesis Synthesis)
+ (function (recur body)
+ (case body
+ (^template [<tag>]
+ (^ (<tag> value))
+ body)
+ ([#//////synthesis.Primitive]
+ [//////synthesis.constant])
+
+ (^ (//////synthesis.variant [lefts right? sub]))
+ (//////synthesis.variant [lefts right? (recur sub)])
+
+ (^ (//////synthesis.tuple members))
+ (//////synthesis.tuple (list@map recur members))
+
+ (^ (//////synthesis.variable var))
+ (|> mapping
+ (dictionary.get var)
+ (maybe.default var)
+ //////synthesis.variable)
+
+ (^ (//////synthesis.branch/case [inputS pathS]))
+ (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)])
+
+ (^ (//////synthesis.branch/let [inputS register outputS]))
+ (//////synthesis.branch/let [(recur inputS) register (recur outputS)])
+
+ (^ (//////synthesis.branch/if [testS thenS elseS]))
+ (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])
+
+ (^ (//////synthesis.loop/scope [offset initsS+ bodyS]))
+ (//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)])
+
+ (^ (//////synthesis.loop/recur updatesS+))
+ (//////synthesis.loop/recur (list@map recur updatesS+))
+
+ (^ (//////synthesis.function/abstraction [environment arity bodyS]))
+ (//////synthesis.function/abstraction [(|> environment (list@map (function (_ local)
+ (|> mapping
+ (dictionary.get local)
+ (maybe.default local)))))
+ arity
+ bodyS])
+
+ (^ (//////synthesis.function/apply [functionS inputsS+]))
+ (//////synthesis.function/apply [(recur functionS) (list@map recur inputsS+)])
+
+ (#//////synthesis.Extension [name inputsS+])
+ (#//////synthesis.Extension [name (list@map recur inputsS+)]))))
+
+(def: $Object (type.class "java.lang.Object" (list)))
+
+(def: (anonymous-init-method env)
+ (-> Environment (Type category.Method))
+ (type.method [(list.repeat (list.size env) ..$Object)
+ type.void
+ (list)]))
+
+(def: (with-anonymous-init class env super-class inputsTG)
+ (-> (Type category.Class) Environment (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method))
+ (let [store-capturedG (|> env
+ list.size
+ list.indices
+ (monad.map _.monad (.function (_ register)
+ ($_ _.compose
+ (_.aload 0)
+ (_.aload (inc register))
+ (_.putfield class (///reference.foreign-name register) $Object)))))]
+ (method.method method.public "<init>" (anonymous-init-method env)
+ (list)
+ (#.Some ($_ _.compose
+ (_.aload 0)
+ (monad.map _.monad product.right inputsTG)
+ (_.invokespecial super-class "<init>" (type.method [(list@map product.left inputsTG) type.void (list)]))
+ store-capturedG
+ _.return)))))
+
+(def: (anonymous-instance class env)
+ (-> (Type category.Class) Environment (Operation (Bytecode Any)))
+ (do /////.monad
+ [captureG+ (monad.map @ ///reference.variable env)]
+ (wrap ($_ _.compose
+ (_.new class)
+ _.dup
+ (monad.seq _.monad captureG+)
+ (_.invokespecial class "<init>" (anonymous-init-method env))))))
+
+(def: (returnG returnT)
+ (-> (Type Return) (Bytecode Any))
+ (case (type.void? returnT)
+ (#.Right returnT)
+ _.return
+
+ (#.Left returnT)
+ (case (type.primitive? returnT)
+ (#.Left returnT)
+ ($_ _.compose
+ (_.checkcast returnT)
+ _.areturn)
+
+ (#.Right returnT)
+ (cond (or (:: type.equivalence = type.boolean returnT)
+ (:: type.equivalence = type.byte returnT)
+ (:: type.equivalence = type.short returnT)
+ (:: type.equivalence = type.int returnT)
+ (:: type.equivalence = type.char returnT))
+ _.ireturn
+
+ (:: type.equivalence = type.long returnT)
+ _.lreturn
+
+ (:: type.equivalence = type.float returnT)
+ _.freturn
+
+ ## (:: type.equivalence = type.double returnT)
+ _.dreturn))))
+
+(def: class::anonymous
+ Handler
+ (..custom
+ [($_ <>.and
+ <s>.text
+ ..class
+ (<s>.tuple (<>.some ..class))
+ (<s>.tuple (<>.some ..input))
+ (<s>.tuple (<>.some ..overriden-method-definition)))
+ (function (_ extension-name generate [class-name
+ super-class super-interfaces
+ inputsTS
+ overriden-methods])
+ (do /////.monad
+ [#let [class (type.class class-name (list))
+ total-environment (|> overriden-methods
+ ## Get all the environments.
+ (list@map product.left)
+ ## Combine them.
+ list@join
+ ## Remove duplicates.
+ (set.from-list //////reference.hash)
+ set.to-list)
+ global-mapping (|> total-environment
+ ## Give them names as "foreign" variables.
+ list.enumerate
+ (list@map (function (_ [id capture])
+ [capture (#//////reference.Foreign id)]))
+ (dictionary.from-list //////reference.hash))
+ normalized-methods (list@map (function (_ [environment
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ body]])
+ (let [local-mapping (|> environment
+ list.enumerate
+ (list@map (function (_ [foreign-id capture])
+ [(#//////reference.Foreign foreign-id)
+ (|> global-mapping
+ (dictionary.get capture)
+ maybe.assume)]))
+ (dictionary.from-list //////reference.hash))]
+ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ (normalize-method-body local-mapping body)]))
+ overriden-methods)]
+ inputsTI (monad.map @ (generate-input generate) inputsTS)
+ method-definitions (monad.map @ (function (_ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ bodyS])
+ (do @
+ [bodyG (generation.with-specific-context class-name
+ (generate bodyS))]
+ (wrap (method.method ($_ modifier@compose
+ method.public
+ method.final
+ (if strict-fp?
+ method.strict
+ modifier@identity))
+ name
+ (type.method [(list@map product.right arguments)
+ returnT
+ exceptionsT])
+ (list)
+ (#.Some ($_ _.compose
+ bodyG
+ (returnG returnT)))))))
+ normalized-methods)
+ bytecode (<| (:: @ map (format.run class.writer))
+ /////.lift
+ (class.class version.v6_0 ($_ modifier@compose class.public class.final)
+ (name.internal class-name)
+ (name.internal (..reflection super-class))
+ (list@map (|>> ..reflection name.internal) super-interfaces)
+ (foreign.variables total-environment)
+ (list& (..with-anonymous-init class total-environment super-class inputsTI)
+ method-definitions)
+ (row.row)))
+ _ (generation.save! true ["" class-name] [class-name bytecode])]
+ (anonymous-instance class total-environment)))]))
+
+(def: bundle::class
+ Bundle
+ (<| (/////bundle.prefix "class")
+ (|> (: Bundle /////bundle.empty)
+ (/////bundle.install "anonymous" class::anonymous)
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (/////bundle.prefix "jvm")
+ (|> ..bundle::conversion
+ (dictionary.merge ..bundle::int)
+ (dictionary.merge ..bundle::long)
+ (dictionary.merge ..bundle::float)
+ (dictionary.merge ..bundle::double)
+ (dictionary.merge ..bundle::char)
+ (dictionary.merge ..bundle::array)
+ (dictionary.merge ..bundle::object)
+ (dictionary.merge ..bundle::member)
+ (dictionary.merge ..bundle::class)
+ )))