aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux753
1 files changed, 753 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
new file mode 100644
index 000000000..45e025d0b
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -0,0 +1,753 @@
+(.module:
+ [lux (#- int char)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["p" parser ("#@." monad)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." error]
+ ["." text
+ format
+ ["l" lexer]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [tool
+ [compiler
+ ["." synthesis (#+ Synthesis %synthesis)]
+ ["." phase ("#@." monad)
+ [generation
+ [extension (#+ Nullary Unary Binary
+ nullary unary binary)]]
+ ["." extension
+ ["." bundle]]]]]
+ [host (#+ import:)]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Primitive Label Inst Method Handler Bundle Operation)
+ ["_t" type]
+ ["_" inst]]]]])
+
+(template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [invalid-syntax-for-jvm-type]
+ [invalid-syntax-for-argument-generation]
+ )
+
+(template [<name> <inst>]
+ [(def: <name>
+ Inst
+ <inst>)]
+
+ [L2S (|>> _.L2I _.I2S)]
+ [L2B (|>> _.L2I _.I2B)]
+ [L2C (|>> _.L2I _.I2C)]
+ )
+
+(template [<name> <unwrap> <conversion> <wrap>]
+ [(def: (<name> inputI)
+ (Unary Inst)
+ (if (is? _.NOP <conversion>)
+ (|>> inputI
+ (_.unwrap <unwrap>)
+ (_.wrap <wrap>))
+ (|>> inputI
+ (_.unwrap <unwrap>)
+ <conversion>
+ (_.wrap <wrap>))))]
+
+ [convert::double-to-float #$.Double _.D2F #$.Float]
+ [convert::double-to-int #$.Double _.D2I #$.Int]
+ [convert::double-to-long #$.Double _.D2L #$.Long]
+ [convert::float-to-double #$.Float _.F2D #$.Double]
+ [convert::float-to-int #$.Float _.F2I #$.Int]
+ [convert::float-to-long #$.Float _.F2L #$.Long]
+ [convert::int-to-byte #$.Int _.I2B #$.Byte]
+ [convert::int-to-char #$.Int _.I2C #$.Char]
+ [convert::int-to-double #$.Int _.I2D #$.Double]
+ [convert::int-to-float #$.Int _.I2F #$.Float]
+ [convert::int-to-long #$.Int _.I2L #$.Long]
+ [convert::int-to-short #$.Int _.I2S #$.Short]
+ [convert::long-to-double #$.Long _.L2D #$.Double]
+ [convert::long-to-float #$.Long _.L2F #$.Float]
+ [convert::long-to-int #$.Long _.L2I #$.Int]
+ [convert::long-to-short #$.Long L2S #$.Short]
+ [convert::long-to-byte #$.Long L2B #$.Byte]
+ [convert::long-to-char #$.Long L2C #$.Char]
+ [convert::char-to-byte #$.Char _.I2B #$.Byte]
+ [convert::char-to-short #$.Char _.I2S #$.Short]
+ [convert::char-to-int #$.Char _.NOP #$.Int]
+ [convert::char-to-long #$.Char _.I2L #$.Long]
+ [convert::byte-to-long #$.Byte _.I2L #$.Long]
+ [convert::short-to-long #$.Short _.I2L #$.Long]
+ )
+
+(def: conversion
+ Bundle
+ (<| (bundle.prefix "convert")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "double-to-float" (unary convert::double-to-float))
+ (bundle.install "double-to-int" (unary convert::double-to-int))
+ (bundle.install "double-to-long" (unary convert::double-to-long))
+ (bundle.install "float-to-double" (unary convert::float-to-double))
+ (bundle.install "float-to-int" (unary convert::float-to-int))
+ (bundle.install "float-to-long" (unary convert::float-to-long))
+ (bundle.install "int-to-byte" (unary convert::int-to-byte))
+ (bundle.install "int-to-char" (unary convert::int-to-char))
+ (bundle.install "int-to-double" (unary convert::int-to-double))
+ (bundle.install "int-to-float" (unary convert::int-to-float))
+ (bundle.install "int-to-long" (unary convert::int-to-long))
+ (bundle.install "int-to-short" (unary convert::int-to-short))
+ (bundle.install "long-to-double" (unary convert::long-to-double))
+ (bundle.install "long-to-float" (unary convert::long-to-float))
+ (bundle.install "long-to-int" (unary convert::long-to-int))
+ (bundle.install "long-to-short" (unary convert::long-to-short))
+ (bundle.install "long-to-byte" (unary convert::long-to-byte))
+ (bundle.install "long-to-char" (unary convert::long-to-char))
+ (bundle.install "char-to-byte" (unary convert::char-to-byte))
+ (bundle.install "char-to-short" (unary convert::char-to-short))
+ (bundle.install "char-to-int" (unary convert::char-to-int))
+ (bundle.install "char-to-long" (unary convert::char-to-long))
+ (bundle.install "byte-to-long" (unary convert::byte-to-long))
+ (bundle.install "short-to-long" (unary convert::short-to-long))
+ )))
+
+(template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (|>> xI (_.unwrap <unwrapX>)
+ yI (_.unwrap <unwrapY>)
+ <op> (_.wrap <wrap>)))]
+
+ [int::+ _.IADD #$.Int #$.Int #$.Int]
+ [int::- _.ISUB #$.Int #$.Int #$.Int]
+ [int::* _.IMUL #$.Int #$.Int #$.Int]
+ [int::/ _.IDIV #$.Int #$.Int #$.Int]
+ [int::% _.IREM #$.Int #$.Int #$.Int]
+ [int::and _.IAND #$.Int #$.Int #$.Int]
+ [int::or _.IOR #$.Int #$.Int #$.Int]
+ [int::xor _.IXOR #$.Int #$.Int #$.Int]
+ [int::shl _.ISHL #$.Int #$.Int #$.Int]
+ [int::shr _.ISHR #$.Int #$.Int #$.Int]
+ [int::ushr _.IUSHR #$.Int #$.Int #$.Int]
+
+ [long::+ _.LADD #$.Long #$.Long #$.Long]
+ [long::- _.LSUB #$.Long #$.Long #$.Long]
+ [long::* _.LMUL #$.Long #$.Long #$.Long]
+ [long::/ _.LDIV #$.Long #$.Long #$.Long]
+ [long::% _.LREM #$.Long #$.Long #$.Long]
+ [long::and _.LAND #$.Long #$.Long #$.Long]
+ [long::or _.LOR #$.Long #$.Long #$.Long]
+ [long::xor _.LXOR #$.Long #$.Long #$.Long]
+ [long::shl _.LSHL #$.Long #$.Int #$.Long]
+ [long::shr _.LSHR #$.Long #$.Int #$.Long]
+ [long::ushr _.LUSHR #$.Long #$.Int #$.Long]
+
+ [float::+ _.FADD #$.Float #$.Float #$.Float]
+ [float::- _.FSUB #$.Float #$.Float #$.Float]
+ [float::* _.FMUL #$.Float #$.Float #$.Float]
+ [float::/ _.FDIV #$.Float #$.Float #$.Float]
+ [float::% _.FREM #$.Float #$.Float #$.Float]
+
+ [double::+ _.DADD #$.Double #$.Double #$.Double]
+ [double::- _.DSUB #$.Double #$.Double #$.Double]
+ [double::* _.DMUL #$.Double #$.Double #$.Double]
+ [double::/ _.DDIV #$.Double #$.Double #$.Double]
+ [double::% _.DREM #$.Double #$.Double #$.Double]
+ )
+
+(def: boolean-class (_t.class "java.lang.Boolean" (list)))
+(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class))
+(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class))
+
+(template [<name> <op> <unwrap>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI (_.unwrap <unwrap>)
+ yI (_.unwrap <unwrap>)
+ (<op> @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [int::= _.IF_ICMPEQ #$.Int]
+ [int::< _.IF_ICMPLT #$.Int]
+
+ [char::= _.IF_ICMPEQ #$.Char]
+ [char::< _.IF_ICMPLT #$.Char]
+ )
+
+(template [<name> <op> <reference> <unwrap>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI (_.unwrap <unwrap>)
+ yI (_.unwrap <unwrap>)
+ <op>
+ (_.int <reference>)
+ (_.IF_ICMPEQ @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [long::= _.LCMP +0 #$.Long]
+ [long::< _.LCMP -1 #$.Long]
+
+ [float::= _.FCMPG +0 #$.Float]
+ [float::< _.FCMPG -1 #$.Float]
+
+ [double::= _.DCMPG +0 #$.Double]
+ [double::< _.DCMPG -1 #$.Double]
+ )
+
+(def: int
+ Bundle
+ (<| (bundle.prefix "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 "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 "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 "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 "char")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "=" (binary char::=))
+ (bundle.install "<" (binary char::<))
+ )))
+
+(def: (array::length arrayD arrayI)
+ (Binary Inst)
+ (|>> arrayI
+ (_.CHECKCAST arrayD)
+ _.ARRAYLENGTH
+ _.I2L
+ (_.wrap #$.Long)))
+
+(def: (array::new proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.i64 level)
+ (synthesis.text class)
+ lengthS))
+ (do phase.monad
+ [lengthI (generate lengthS)
+ #let [arrayJT (_t.array (.nat level)
+ (case class
+ "boolean" _t.boolean
+ "byte" _t.byte
+ "short" _t.short
+ "int" _t.int
+ "long" _t.long
+ "float" _t.float
+ "double" _t.double
+ "char" _t.char
+ _ (_t.class class (list))))]]
+ (wrap (|>> lengthI
+ (_.unwrap #$.Long)
+ _.L2I
+ (_.array arrayJT))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (array::read proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ idxS
+ arrayS))
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)
+ #let [loadI (case class
+ "boolean" (|>> _.BALOAD (_.wrap #$.Boolean))
+ "byte" (|>> _.BALOAD (_.wrap #$.Byte))
+ "short" (|>> _.SALOAD (_.wrap #$.Short))
+ "int" (|>> _.IALOAD (_.wrap #$.Int))
+ "long" (|>> _.LALOAD (_.wrap #$.Long))
+ "float" (|>> _.FALOAD (_.wrap #$.Float))
+ "double" (|>> _.DALOAD (_.wrap #$.Double))
+ "char" (|>> _.CALOAD (_.wrap #$.Char))
+ _ _.AALOAD)]]
+ (wrap (|>> arrayI
+ idxI
+ (_.unwrap #$.Long)
+ _.L2I
+ loadI)))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (array::write proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ idxS
+ valueS
+ arrayS))
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)
+ valueI (generate valueS)
+ #let [storeI (case class
+ "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE)
+ "byte" (|>> (_.unwrap #$.Byte) _.BASTORE)
+ "short" (|>> (_.unwrap #$.Short) _.SASTORE)
+ "int" (|>> (_.unwrap #$.Int) _.IASTORE)
+ "long" (|>> (_.unwrap #$.Long) _.LASTORE)
+ "float" (|>> (_.unwrap #$.Float) _.FASTORE)
+ "double" (|>> (_.unwrap #$.Double) _.DASTORE)
+ "char" (|>> (_.unwrap #$.Char) _.CASTORE)
+ _ _.AASTORE)]]
+ (wrap (|>> arrayI
+ _.DUP
+ idxI
+ (_.unwrap #$.Long)
+ _.L2I
+ valueI
+ storeI)))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "length" (unary array::length))
+ (bundle.install "new" array::new)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ )))
+
+(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: (object::class proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)))
+ (do phase.monad
+ []
+ (wrap (|>> (_.string class)
+ (_.INVOKESTATIC "java.lang.Class" "forName"
+ (_t.method (list (_t.class "java.lang.String" (list)))
+ (#.Some (_t.class "java.lang.Class" (list)))
+ (list))
+ false))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (object::instance? proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class) objectS))
+ (do phase.monad
+ [objectI (generate objectS)]
+ (wrap (|>> objectI
+ (_.INSTANCEOF class)
+ (_.wrap #$.Boolean))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (object::cast proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text from) (synthesis.text to) valueS))
+ (do phase.monad
+ [valueI (generate valueS)]
+ (case [from to]
+ ## Wrap
+ (^template [<primitive> <object> <type>]
+ [<primitive> <object>]
+ (wrap (|>> valueI (_.wrap <type>)))
+
+ [<object> <primitive>]
+ (wrap (|>> valueI (_.unwrap <type>))))
+ (["boolean" "java.lang.Boolean" #$.Boolean]
+ ["byte" "java.lang.Byte" #$.Byte]
+ ["short" "java.lang.Short" #$.Short]
+ ["int" "java.lang.Integer" #$.Int]
+ ["long" "java.lang.Long" #$.Long]
+ ["float" "java.lang.Float" #$.Float]
+ ["double" "java.lang.Double" #$.Double]
+ ["char" "java.lang.Character" #$.Char])
+
+ _
+ (wrap valueI)))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: 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 Primitive)
+ (|> (list ["boolean" #$.Boolean]
+ ["byte" #$.Byte]
+ ["short" #$.Short]
+ ["int" #$.Int]
+ ["long" #$.Long]
+ ["float" #$.Float]
+ ["double" #$.Double]
+ ["char" #$.Char])
+ (dictionary.from-list text.hash)))
+
+(def: (static::get proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)))
+ (do phase.monad
+ []
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive))
+ (_.wrap primitive)))
+
+ #.None
+ (wrap (_.GETSTATIC class field (_t.class unboxed (list))))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (static::put proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)
+ valueS))
+ (do phase.monad
+ [valueI (generate valueS)]
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> valueI
+ (_.unwrap primitive)
+ (_.PUTSTATIC class field (#$.Primitive primitive))
+ (_.string synthesis.unit)))
+
+ #.None
+ (wrap (|>> valueI
+ (_.CHECKCAST class)
+ (_.PUTSTATIC class field (_t.class class (list)))
+ (_.string synthesis.unit)))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (virtual::get proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)
+ objectS))
+ (do phase.monad
+ [objectI (generate objectS)]
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.GETFIELD class field (#$.Primitive primitive))
+ (_.wrap primitive)))
+
+ #.None
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.GETFIELD class field (_t.class unboxed (list)))))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (virtual::put proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)
+ valueS
+ objectS))
+ (do phase.monad
+ [valueI (generate valueS)
+ objectI (generate objectS)]
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ _.DUP
+ valueI
+ (_.unwrap primitive)
+ (_.PUTFIELD class field (#$.Primitive primitive))))
+
+ #.None
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ _.DUP
+ valueI
+ (_.CHECKCAST unboxed)
+ (_.PUTFIELD class field (_t.class unboxed (list)))))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: base-type
+ (l.Lexer $.Type)
+ ($_ p.either
+ (p.after (l.this "boolean") (p@wrap _t.boolean))
+ (p.after (l.this "byte") (p@wrap _t.byte))
+ (p.after (l.this "short") (p@wrap _t.short))
+ (p.after (l.this "int") (p@wrap _t.int))
+ (p.after (l.this "long") (p@wrap _t.long))
+ (p.after (l.this "float") (p@wrap _t.float))
+ (p.after (l.this "double") (p@wrap _t.double))
+ (p.after (l.this "char") (p@wrap _t.char))
+ (p@map (function (_ name)
+ (_t.class name (list)))
+ (l.many (l.none-of "[")))
+ ))
+
+(def: java-type
+ (l.Lexer $.Type)
+ (do p.monad
+ [raw base-type
+ nesting (p.some (l.this "[]"))]
+ (wrap (_t.array (list.size nesting) raw))))
+
+(def: (generate-type argD)
+ (-> Text (Operation $.Type))
+ (case (l.run argD java-type)
+ (#error.Failure error)
+ (phase.throw invalid-syntax-for-jvm-type argD)
+
+ (#error.Success type)
+ (phase@wrap type)))
+
+(def: (generate-arg generate argS)
+ (-> (-> Synthesis (Operation Inst)) Synthesis
+ (Operation [$.Type Inst]))
+ (case argS
+ (^ (synthesis.tuple (list (synthesis.text argD) argS)))
+ (do phase.monad
+ [argT (generate-type argD)
+ argI (generate argS)]
+ (wrap [argT argI]))
+
+ _
+ (phase.throw invalid-syntax-for-argument-generation "")))
+
+(def: (method-return-type description)
+ (-> Text (Operation (Maybe $.Type)))
+ (case description
+ "void"
+ (phase@wrap #.None)
+
+ _
+ (phase@map (|>> #.Some) (generate-type description))))
+
+(def: (invoke::static proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list& (synthesis.text class)
+ (synthesis.text method)
+ (synthesis.text unboxed)
+ argsS))
+ (do phase.monad
+ [argsTI (monad.map @ (generate-arg generate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> (_.fuse (list@map product.right argsTI))
+ (_.INVOKESTATIC class method
+ (_t.method (list@map product.left argsTI) returnT (list))
+ false))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(template [<name> <invoke> <interface?>]
+ [(def: (<name> proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list& (synthesis.text class)
+ (synthesis.text method)
+ (synthesis.text unboxed)
+ objectS
+ argsS))
+ (do phase.monad
+ [objectI (generate objectS)
+ argsTI (monad.map @ (generate-arg generate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.fuse (list@map product.right argsTI))
+ (<invoke> class method
+ (_t.method (list@map product.left argsTI) returnT (list))
+ <interface?>))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))]
+
+ [invoke::virtual _.INVOKEVIRTUAL false]
+ [invoke::special _.INVOKESPECIAL false]
+ [invoke::interface _.INVOKEINTERFACE true]
+ )
+
+(def: (invoke::constructor proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list& (synthesis.text class) argsS))
+ (do phase.monad
+ [argsTI (monad.map @ (generate-arg generate) argsS)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse (list@map product.right argsTI))
+ (_.INVOKESPECIAL class "<init>"
+ (_t.method (list@map product.left argsTI) #.None (list))
+ false))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: member
+ Bundle
+ (<| (bundle.prefix "member")
+ (|> (: Bundle bundle.empty)
+ (dictionary.merge (<| (bundle.prefix "static")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "get" static::get)
+ (bundle.install "put" static::put))))
+ (dictionary.merge (<| (bundle.prefix "virtual")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "get" virtual::get)
+ (bundle.install "put" virtual::put))))
+ (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: #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)
+ (dictionary.merge ..member)
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-15 23:41:30 +0000