aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
diff options
context:
space:
mode:
Diffstat (limited to 'lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux')
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux1047
1 files changed, 1047 insertions, 0 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
new file mode 100644
index 000000000..7b90a8e4f
--- /dev/null
+++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
@@ -0,0 +1,1047 @@
+(.module:
+ [lux (#- Type primitive int char type)
+ [host (#+ import:)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ ["." function]
+ ["<>" parser ("#@." monad)
+ ["<t>" text]
+ ["<s>" synthesis (#+ Parser)]]]
+ [data
+ ["." product]
+ ["." maybe]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
+ [number
+ ["." nat]]
+ [collection
+ ["." list ("#@." monad)]
+ ["." dictionary (#+ Dictionary)]
+ ["." set]]]
+ [target
+ [jvm
+ ["." type (#+ Type Typed Argument)
+ ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
+ ["." box]
+ ["." reflection]
+ ["." signature]
+ ["." parser]]]]
+ [tool
+ [compiler
+ ["." reference (#+ Variable)]
+ ["." phase ("#@." monad)]
+ [meta
+ [archive (#+ Archive)]]
+ [language
+ [lux
+ [analysis (#+ Environment)]
+ ["." synthesis (#+ Synthesis Path %synthesis)]
+ ["." generation]
+ [phase
+ [generation
+ [extension (#+ Nullary Unary Binary
+ nullary unary binary)]]
+ [analysis
+ [".A" reference]]
+ ["." extension
+ ["." bundle]
+ [analysis
+ ["/" jvm]]]]]]]]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
+ ["_" inst]
+ ["_." def]]]]]
+ ["." // #_
+ [common (#+ custom)]
+ ["/#" //
+ ["#." reference]
+ ["#." function]]])
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<t>.embed <parser> <s>.text))]
+
+ [var Var parser.var]
+ [class 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))))
+
+(template [<name> <inst>]
+ [(def: <name>
+ Inst
+ <inst>)]
+
+ [L2S (|>> _.L2I _.I2S)]
+ [L2B (|>> _.L2I _.I2B)]
+ [L2C (|>> _.L2I _.I2C)]
+ )
+
+(template [<conversion> <name>]
+ [(def: (<name> inputI)
+ (Unary Inst)
+ (if (is? _.NOP <conversion>)
+ inputI
+ (|>> inputI
+ <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: 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> [xI yI])
+ (Binary Inst)
+ (|>> xI
+ yI
+ <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: falseI (_.GETSTATIC $Boolean "FALSE" $Boolean))
+(def: trueI (_.GETSTATIC $Boolean "TRUE" $Boolean))
+
+(template [<name> <op>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI
+ yI
+ (<op> @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [int::= _.IF_ICMPEQ]
+ [int::< _.IF_ICMPLT]
+
+ [char::= _.IF_ICMPEQ]
+ [char::< _.IF_ICMPLT]
+ )
+
+(template [<name> <op> <reference>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI
+ yI
+ <op>
+ (_.int <reference>)
+ (_.IF_ICMPEQ @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [long::= _.LCMP +0]
+ [long::< _.LCMP -1]
+
+ [float::= _.FCMPG +0]
+ [float::< _.FCMPG -1]
+
+ [double::= _.DCMPG +0]
+ [double::< _.DCMPG -1]
+ )
+
+(def: 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: 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: 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: 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: char
+ Bundle
+ (<| (bundle.prefix (reflection.reflection reflection.char))
+ (|> (: Bundle bundle.empty)
+ (bundle.install "=" (binary char::=))
+ (bundle.install "<" (binary char::<))
+ )))
+
+(def: (primitive-array-length-handler jvm-primitive)
+ (-> (Type Primitive) Handler)
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate archive arrayS)
+ (do phase.monad
+ [arrayI (generate archive arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array jvm-primitive))
+ _.ARRAYLENGTH))))]))
+
+(def: array::length::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any)
+ (function (_ extension-name generate archive [elementJT arrayS])
+ (do phase.monad
+ [arrayI (generate archive arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ _.ARRAYLENGTH))))]))
+
+(def: (new-primitive-array-handler jvm-primitive)
+ (-> (Type Primitive) Handler)
+ (function (_ extension-name generate archive inputs)
+ (case inputs
+ (^ (list lengthS))
+ (do phase.monad
+ [lengthI (generate archive lengthS)]
+ (wrap (|>> lengthI
+ (_.array jvm-primitive))))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: array::new::object
+ Handler
+ (..custom
+ [($_ <>.and ..object <s>.any)
+ (function (_ extension-name generate archive [objectJT lengthS])
+ (do phase.monad
+ [lengthI (generate archive lengthS)]
+ (wrap (|>> lengthI
+ (_.ANEWARRAY objectJT)))))]))
+
+(def: (read-primitive-array-handler jvm-primitive loadI)
+ (-> (Type Primitive) Inst Handler)
+ (function (_ extension-name generate archive inputs)
+ (case inputs
+ (^ (list idxS arrayS))
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array jvm-primitive))
+ idxI
+ loadI)))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: array::read::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any)
+ (function (_ extension-name generate archive [elementJT idxS arrayS])
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ idxI
+ _.AALOAD))))]))
+
+(def: (write-primitive-array-handler jvm-primitive storeI)
+ (-> (Type Primitive) Inst Handler)
+ (function (_ extension-name generate archive inputs)
+ (case inputs
+ (^ (list idxS valueS arrayS))
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)
+ valueI (generate archive valueS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array jvm-primitive))
+ _.DUP
+ idxI
+ valueI
+ storeI)))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: array::write::object
+ Handler
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate archive [elementJT idxS valueS arrayS])
+ (do phase.monad
+ [arrayI (generate archive arrayS)
+ idxI (generate archive idxS)
+ valueI (generate archive valueS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ _.DUP
+ idxI
+ valueI
+ _.AASTORE))))]))
+
+(def: 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 type.boolean))
+ (bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler type.byte))
+ (bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler type.short))
+ (bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler type.int))
+ (bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler type.long))
+ (bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler type.float))
+ (bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler type.double))
+ (bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler type.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 Inst)
+ _.NULL)
+
+(def: (object::null? objectI)
+ (Unary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> objectI
+ (_.IFNULL @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))
+
+(def: (object::synchronized [monitorI exprI])
+ (Binary Inst)
+ (|>> monitorI
+ _.DUP
+ _.MONITORENTER
+ exprI
+ _.SWAP
+ _.MONITOREXIT))
+
+(def: (object::throw exceptionI)
+ (Unary Inst)
+ (|>> exceptionI
+ _.ATHROW))
+
+(def: $Class (type.class "java.lang.Class" (list)))
+
+(def: (object::class extension-name generate archive inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)))
+ (do phase.monad
+ []
+ (wrap (|>> (_.string class)
+ (_.INVOKESTATIC $Class "forName" (type.method [(list (type.class "java.lang.String" (list))) $Class (list)])))))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+
+(def: object::instance?
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension-name generate archive [class objectS])
+ (do phase.monad
+ [objectI (generate archive objectS)]
+ (wrap (|>> objectI
+ (_.INSTANCEOF (type.class class (list)))
+ (_.wrap type.boolean)))))]))
+
+(def: (object::cast extension-name generate archive inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text from) (synthesis.text to) valueS))
+ (do phase.monad
+ [valueI (generate archive valueS)]
+ (`` (cond (~~ (template [<object> <type>]
+ [(and (text@= (reflection.reflection (type.reflection <type>))
+ from)
+ (text@= <object>
+ to))
+ (wrap (|>> valueI (_.wrap <type>)))
+
+ (and (text@= <object>
+ from)
+ (text@= (reflection.reflection (type.reflection <type>))
+ to))
+ (wrap (|>> valueI (_.unwrap <type>)))]
+
+ [box.boolean type.boolean]
+ [box.byte type.byte]
+ [box.short type.short]
+ [box.int type.int]
+ [box.long type.long]
+ [box.float type.float]
+ [box.double type.double]
+ [box.char type.char]))
+ ## else
+ (wrap valueI))))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+
+(def: object-bundle
+ 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 archive [class field unboxed])
+ (do phase.monad
+ []
+ (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (wrap (_.GETSTATIC (type.class class (list)) field primitive))
+
+ #.None
+ (wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))]))
+
+(def: put::static
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [class field unboxed valueS])
+ (do phase.monad
+ [valueI (generate archive valueS)
+ #let [$class (type.class class (list))]]
+ (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (wrap (|>> valueI
+ (_.PUTSTATIC $class field primitive)
+ (_.string synthesis.unit)))
+
+ #.None
+ (wrap (|>> valueI
+ (_.CHECKCAST $class)
+ (_.PUTSTATIC $class field $class)
+ (_.string synthesis.unit))))))]))
+
+(def: get::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+ (function (_ extension-name generate archive [class field unboxed objectS])
+ (do phase.monad
+ [objectI (generate archive objectS)
+ #let [$class (type.class class (list))
+ getI (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (_.GETFIELD $class field primitive)
+
+ #.None
+ (_.GETFIELD $class field (type.class unboxed (list))))]]
+ (wrap (|>> objectI
+ (_.CHECKCAST $class)
+ getI))))]))
+
+(def: put::virtual
+ Handler
+ (..custom
+ [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
+ (function (_ extension-name generate archive [class field unboxed valueS objectS])
+ (do phase.monad
+ [valueI (generate archive valueS)
+ objectI (generate archive objectS)
+ #let [$class (type.class class (list))
+ putI (case (dictionary.get unboxed ..primitives)
+ (#.Some primitive)
+ (_.PUTFIELD $class field primitive)
+
+ #.None
+ (let [$unboxed (type.class unboxed (list))]
+ (|>> (_.CHECKCAST $unboxed)
+ (_.PUTFIELD $class field $unboxed))))]]
+ (wrap (|>> objectI
+ (_.CHECKCAST $class)
+ _.DUP
+ valueI
+ putI))))]))
+
+(type: Input (Typed Synthesis))
+
+(def: input
+ (Parser Input)
+ (<s>.tuple (<>.and ..value <s>.any)))
+
+(def: (generate-input generate archive [valueT valueS])
+ (-> Phase Archive Input
+ (Operation (Typed Inst)))
+ (do phase.monad
+ [valueI (generate archive valueS)]
+ (case (type.primitive? valueT)
+ (#.Right valueT)
+ (wrap [valueT valueI])
+
+ (#.Left valueT)
+ (wrap [valueT (|>> valueI
+ (_.CHECKCAST valueT))]))))
+
+(def: voidI (_.string synthesis.unit))
+
+(def: (prepare-output outputT)
+ (-> (Type Return) Inst)
+ (case (type.void? outputT)
+ (#.Right outputT)
+ ..voidI
+
+ (#.Left outputT)
+ function.identity))
+
+(def: invoke::static
+ Handler
+ (..custom
+ [($_ <>.and ..class <s>.text ..return (<>.some ..input))
+ (function (_ extension-name generate archive [class method outputT inputsTS])
+ (do {@ phase.monad}
+ [inputsTI (monad.map @ (generate-input generate archive) inputsTS)]
+ (wrap (|>> (_.fuse (list@map product.right inputsTI))
+ (_.INVOKESTATIC class method (type.method [(list@map product.left inputsTI) 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 archive [class method outputT objectS inputsTS])
+ (do {@ phase.monad}
+ [objectI (generate archive objectS)
+ inputsTI (monad.map @ (generate-input generate archive) inputsTS)]
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.fuse (list@map product.right inputsTI))
+ (<invoke> class method
+ (type.method [(list@map product.left inputsTI)
+ 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 archive [class inputsTS])
+ (do {@ phase.monad}
+ [inputsTI (monad.map @ (generate-input generate archive) inputsTS)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse (list@map product.right inputsTI))
+ (_.INVOKESPECIAL class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)]))))))]))
+
+(def: 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 Method))
+ (type.method [(list.repeat (list.size env) $Object)
+ type.void
+ (list)]))
+
+(def: (with-anonymous-init class env super-class inputsTI)
+ (-> (Type Class) Environment (Type Class) (List (Typed Inst)) Def)
+ (let [store-capturedI (|> env
+ list.size
+ list.indices
+ (list@map (.function (_ register)
+ (|>> (_.ALOAD 0)
+ (_.ALOAD (inc register))
+ (_.PUTFIELD class (///reference.foreign-name register) $Object))))
+ _.fuse)]
+ (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env)
+ (|>> (_.ALOAD 0)
+ ((_.fuse (list@map product.right inputsTI)))
+ (_.INVOKESPECIAL super-class "<init>" (type.method [(list@map product.left inputsTI) type.void (list)]))
+ store-capturedI
+ _.RETURN))))
+
+(def: (anonymous-instance archive class env)
+ (-> Archive (Type Class) Environment (Operation Inst))
+ (do {@ phase.monad}
+ [captureI+ (monad.map @ (///reference.variable archive) env)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse captureI+)
+ (_.INVOKESPECIAL class "<init>" (anonymous-init-method env))))))
+
+(def: (returnI returnT)
+ (-> (Type Return) Inst)
+ (case (type.void? returnT)
+ (#.Right returnT)
+ _.RETURN
+
+ (#.Left returnT)
+ (case (type.primitive? returnT)
+ (#.Left returnT)
+ (|>> (_.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
+ ..class
+ (<s>.tuple (<>.some ..class))
+ (<s>.tuple (<>.some ..input))
+ (<s>.tuple (<>.some ..overriden-method-definition)))
+ (function (_ extension-name generate archive [super-class super-interfaces
+ inputsTS
+ overriden-methods])
+ (do {@ phase.monad}
+ [[context _] (generation.with-new-context archive (wrap []))
+ #let [[module-id artifact-id] context
+ anonymous-class-name (///.class-name context)
+ class (type.class anonymous-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 archive) inputsTS)
+ method-definitions (|> normalized-methods
+ (monad.map @ (function (_ [ownerT name
+ strict-fp? annotations vars
+ self-name arguments returnT exceptionsT
+ bodyS])
+ (do @
+ [bodyG (generation.with-context artifact-id
+ (generate archive bodyS))]
+ (wrap (_def.method #$.Public
+ (if strict-fp?
+ ($_ $.++M $.finalM $.strictM)
+ $.finalM)
+ name
+ (type.method [(list@map product.right arguments)
+ returnT
+ exceptionsT])
+ (|>> bodyG (returnI returnT)))))))
+ (:: @ map _def.fuse))
+ _ (generation.save! true ["" (%.nat artifact-id)]
+ [anonymous-class-name
+ (_def.class #$.V1_6 #$.Public $.finalC
+ anonymous-class-name (list)
+ super-class super-interfaces
+ (|>> (///function.with-environment total-environment)
+ (..with-anonymous-init class total-environment super-class inputsTI)
+ method-definitions))])]
+ (anonymous-instance archive 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")
+ (|> ..conversion
+ (dictionary.merge ..int)
+ (dictionary.merge ..long)
+ (dictionary.merge ..float)
+ (dictionary.merge ..double)
+ (dictionary.merge ..char)
+ (dictionary.merge ..array)
+ (dictionary.merge ..object-bundle)
+ (dictionary.merge ..member)
+ (dictionary.merge ..bundle::class)
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 01:27:35 +0000