aboutsummaryrefslogtreecommitdiff
path: root/lux-jvm/source/luxc/lang/translation/jvm/extension
diff options
context:
space:
mode:
authorEduardo Julian2022-04-05 18:32:42 -0400
committerEduardo Julian2022-04-05 18:32:42 -0400
commit60daee098f92a44c3b404a9f5801f2e8126ad650 (patch)
tree7b58d0f6f937b8be5dcb46eaf0411f7961907c8a /lux-jvm/source/luxc/lang/translation/jvm/extension
parenta2d994a3f7a39964452df7523f69e16b10b266f9 (diff)
No longer depending on the ASM library for JVM bytecode generation.
Diffstat (limited to 'lux-jvm/source/luxc/lang/translation/jvm/extension')
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux359
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux1248
2 files changed, 0 insertions, 1607 deletions
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
deleted file mode 100644
index 10fe4e948..000000000
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux
+++ /dev/null
@@ -1,359 +0,0 @@
-(.using
- [library
- [lux {"-" Type Label}
- [ffi {"+" import:}]
- [abstract
- ["[0]" monad {"+" do}]]
- [control
- ["[0]" try]
- ["<>" parser
- ["<s>" synthesis {"+" Parser}]]]
- [data
- ["[0]" product]
- [collection
- ["[0]" list ("[1]@[0]" monad)]
- ["[0]" dictionary]]]
- [math
- [number
- ["f" frac]]]
- [target
- [jvm
- ["[0]" type]]]
- [tool
- [compiler
- ["[0]" phase]
- [meta
- [archive {"+" Archive}]]
- [language
- [lux
- ["[0]" synthesis {"+" Synthesis %synthesis}]
- [phase
- [generation
- [extension {"+" Nullary Unary Binary Trinary Variadic
- nullary unary binary trinary variadic}]]
- ["[0]" extension
- ["[0]" bundle]]]]]]]]]
- [luxc
- [lang
- [host
- ["$" jvm {"+" Label Inst Def Handler Bundle Operation Phase}
- ["_" inst]]]]]
- ["[0]" ///
- ["[0]" runtime]])
-
-(def: .public (custom [parser handler])
- (All (_ s)
- (-> [(Parser s)
- (-> Text Phase Archive s (Operation Inst))]
- Handler))
- (function (_ extension_name phase archive input)
- (case (<s>.result parser input)
- {try.#Success input'}
- (handler extension_name phase archive input')
-
- {try.#Failure error}
- (phase.except extension.invalid_syntax [extension_name %synthesis input]))))
-
-(def: $String (type.class "java.lang.String" (list)))
-(def: $CharSequence (type.class "java.lang.CharSequence" (list)))
-(def: $System (type.class "java.lang.System" (list)))
-(def: $Object (type.class "java.lang.Object" (list)))
-
-(def: lux_intI Inst (|>> _.I2L (_.wrap type.long)))
-(def: jvm_intI Inst (|>> (_.unwrap type.long) _.L2I))
-(def: check_stringI Inst (_.CHECKCAST $String))
-
-(def: (predicateI tester)
- (-> (-> Label Inst)
- Inst)
- (let [$Boolean (type.class "java.lang.Boolean" (list))]
- (<| _.with_label (function (_ @then))
- _.with_label (function (_ @end))
- (|>> (tester @then)
- (_.GETSTATIC $Boolean "FALSE" $Boolean)
- (_.GOTO @end)
- (_.label @then)
- (_.GETSTATIC $Boolean "TRUE" $Boolean)
- (_.label @end)
- ))))
-
-(def: unitI Inst (_.string synthesis.unit))
-
-... TODO: Get rid of this ASAP
-(def: lux::syntax_char_case!
- (..custom [($_ <>.and
- <s>.any
- <s>.any
- (<>.some (<s>.tuple ($_ <>.and
- (<s>.tuple (<>.many <s>.i64))
- <s>.any))))
- (function (_ extension_name phase archive [input else conditionals])
- (<| _.with_label (function (_ @end))
- _.with_label (function (_ @else))
- (do [@ phase.monad]
- [inputG (phase archive input)
- elseG (phase archive else)
- conditionalsG+ (is (Operation (List [(List [Int Label])
- Inst]))
- (monad.each @ (function (_ [chars branch])
- (do @
- [branchG (phase archive branch)]
- (in (<| _.with_label (function (_ @branch))
- [(list@each (function (_ char)
- [(.int char) @branch])
- chars)
- (|>> (_.label @branch)
- branchG
- (_.GOTO @end))]))))
- conditionals))
- .let [table (|> conditionalsG+
- (list@each product.left)
- list@conjoint)
- conditionalsG (|> conditionalsG+
- (list@each product.right)
- _.fuse)]]
- (in (|>> inputG (_.unwrap type.long) _.L2I
- (_.LOOKUPSWITCH @else table)
- conditionalsG
- (_.label @else)
- elseG
- (_.label @end))))))]))
-
-(def: (lux::is [referenceI sampleI])
- (Binary Inst)
- (|>> referenceI
- sampleI
- (predicateI _.IF_ACMPEQ)))
-
-(def: (lux::try riskyI)
- (Unary Inst)
- (|>> riskyI
- (_.CHECKCAST ///.$Function)
- (_.INVOKESTATIC ///.$Runtime "try" runtime.try)))
-
-(template [<name> <op>]
- [(def: (<name> [maskI inputI])
- (Binary Inst)
- (|>> inputI (_.unwrap type.long)
- maskI (_.unwrap type.long)
- <op> (_.wrap type.long)))]
-
- [i64::and _.LAND]
- [i64::or _.LOR]
- [i64::xor _.LXOR]
- )
-
-(template [<name> <op>]
- [(def: (<name> [shiftI inputI])
- (Binary Inst)
- (|>> inputI (_.unwrap type.long)
- shiftI jvm_intI
- <op>
- (_.wrap type.long)))]
-
- [i64::left_shift _.LSHL]
- [i64::right_shift _.LUSHR]
- )
-
-(template [<name> <type> <op>]
- [(def: (<name> [paramI subjectI])
- (Binary Inst)
- (|>> subjectI (_.unwrap <type>)
- paramI (_.unwrap <type>)
- <op>
- (_.wrap <type>)))]
-
- [i64::+ type.long _.LADD]
- [i64::- type.long _.LSUB]
- [i64::* type.long _.LMUL]
- [i64::/ type.long _.LDIV]
- [i64::% type.long _.LREM]
-
- [f64::+ type.double _.DADD]
- [f64::- type.double _.DSUB]
- [f64::* type.double _.DMUL]
- [f64::/ type.double _.DDIV]
- [f64::% type.double _.DREM]
- )
-
-(template [<eq> <lt> <type> <cmp>]
- [(template [<name> <reference>]
- [(def: (<name> [paramI subjectI])
- (Binary Inst)
- (|>> subjectI (_.unwrap <type>)
- paramI (_.unwrap <type>)
- <cmp>
- (_.int <reference>)
- (predicateI _.IF_ICMPEQ)))]
-
- [<eq> +0]
- [<lt> -1])]
-
- [i64::= i64::< type.long _.LCMP]
- [f64::= f64::< type.double _.DCMPG]
- )
-
-(template [<name> <prepare> <transform>]
- [(def: (<name> inputI)
- (Unary Inst)
- (|>> inputI <prepare> <transform>))]
-
- [i64::f64 (_.unwrap type.long) (<| (_.wrap type.double) _.L2D)]
- [i64::char (_.unwrap type.long)
- ((|>> _.L2I _.I2C (_.INVOKESTATIC (type.class "java.lang.Character" (list)) "toString" (type.method [(list) (list type.char) $String (list)]))))]
-
- [f64::i64 (_.unwrap type.double) (<| (_.wrap type.long) _.D2L)]
- [f64::encode (_.unwrap type.double)
- (_.INVOKESTATIC (type.class "java.lang.Double" (list)) "toString" (type.method [(list) (list type.double) $String (list)]))]
- [f64::decode ..check_stringI
- (_.INVOKESTATIC ///.$Runtime "decode_frac" (type.method [(list) (list $String) ///.$Variant (list)]))]
- )
-
-(def: (text::size inputI)
- (Unary Inst)
- (|>> inputI
- ..check_stringI
- (_.INVOKEVIRTUAL $String "length" (type.method [(list) (list) type.int (list)]))
- lux_intI))
-
-(template [<name> <pre_subject> <pre_param> <op> <post>]
- [(def: (<name> [paramI subjectI])
- (Binary Inst)
- (|>> subjectI <pre_subject>
- paramI <pre_param>
- <op> <post>))]
-
- [text::= (<|) (<|)
- (_.INVOKEVIRTUAL $Object "equals" (type.method [(list) (list $Object) type.boolean (list)]))
- (_.wrap type.boolean)]
- [text::< ..check_stringI ..check_stringI
- (_.INVOKEVIRTUAL $String "compareTo" (type.method [(list) (list $String) type.int (list)]))
- (predicateI _.IFLT)]
- [text::char ..check_stringI jvm_intI
- (_.INVOKEVIRTUAL $String "charAt" (type.method [(list) (list type.int) type.char (list)]))
- lux_intI]
- )
-
-(def: (text::concat [leftI rightI])
- (Binary Inst)
- (|>> leftI ..check_stringI
- rightI ..check_stringI
- (_.INVOKEVIRTUAL $String "concat" (type.method [(list) (list $String) $String (list)]))))
-
-(def: (text::clip [offsetI lengthI subjectI])
- (Trinary Inst)
- (|>> subjectI ..check_stringI
- offsetI jvm_intI
- _.DUP
- lengthI jvm_intI
- _.IADD
- (_.INVOKEVIRTUAL $String "substring" (type.method [(list) (list type.int type.int) $String (list)]))))
-
-(def: index_method (type.method [(list) (list $String type.int) type.int (list)]))
-(def: (text::index [startI partI textI])
- (Trinary Inst)
- (<| _.with_label (function (_ @not_found))
- _.with_label (function (_ @end))
- (|>> textI ..check_stringI
- partI ..check_stringI
- startI jvm_intI
- (_.INVOKEVIRTUAL $String "indexOf" index_method)
- _.DUP
- (_.int -1)
- (_.IF_ICMPEQ @not_found)
- lux_intI
- runtime.someI
- (_.GOTO @end)
- (_.label @not_found)
- _.POP
- runtime.noneI
- (_.label @end))))
-
-(def: string_method (type.method [(list) (list $String) type.void (list)]))
-(def: (io::log messageI)
- (Unary Inst)
- (let [$PrintStream (type.class "java.io.PrintStream" (list))]
- (|>> (_.GETSTATIC $System "out" $PrintStream)
- messageI
- ..check_stringI
- (_.INVOKEVIRTUAL $PrintStream "println" string_method)
- unitI)))
-
-(def: (io::error messageI)
- (Unary Inst)
- (let [$Error (type.class "java.lang.Error" (list))]
- (|>> (_.NEW $Error)
- _.DUP
- messageI
- ..check_stringI
- (_.INVOKESPECIAL $Error "<init>" string_method)
- _.ATHROW)))
-
-(def: bundle::lux
- Bundle
- (|> (is Bundle bundle.empty)
- (bundle.install "syntax char case!" lux::syntax_char_case!)
- (bundle.install "is" (binary lux::is))
- (bundle.install "try" (unary lux::try))))
-
-(def: bundle::i64
- Bundle
- (<| (bundle.prefix "i64")
- (|> (is Bundle bundle.empty)
- (bundle.install "and" (binary i64::and))
- (bundle.install "or" (binary i64::or))
- (bundle.install "xor" (binary i64::xor))
- (bundle.install "left-shift" (binary i64::left_shift))
- (bundle.install "right-shift" (binary i64::right_shift))
- (bundle.install "=" (binary i64::=))
- (bundle.install "<" (binary i64::<))
- (bundle.install "+" (binary i64::+))
- (bundle.install "-" (binary i64::-))
- (bundle.install "*" (binary i64::*))
- (bundle.install "/" (binary i64::/))
- (bundle.install "%" (binary i64::%))
- (bundle.install "f64" (unary i64::f64))
- (bundle.install "char" (unary i64::char)))))
-
-(def: bundle::f64
- Bundle
- (<| (bundle.prefix "f64")
- (|> (is Bundle bundle.empty)
- (bundle.install "+" (binary f64::+))
- (bundle.install "-" (binary f64::-))
- (bundle.install "*" (binary f64::*))
- (bundle.install "/" (binary f64::/))
- (bundle.install "%" (binary f64::%))
- (bundle.install "=" (binary f64::=))
- (bundle.install "<" (binary f64::<))
- (bundle.install "i64" (unary f64::i64))
- (bundle.install "encode" (unary f64::encode))
- (bundle.install "decode" (unary f64::decode)))))
-
-(def: bundle::text
- Bundle
- (<| (bundle.prefix "text")
- (|> (is Bundle bundle.empty)
- (bundle.install "=" (binary text::=))
- (bundle.install "<" (binary text::<))
- (bundle.install "concat" (binary text::concat))
- (bundle.install "index" (trinary text::index))
- (bundle.install "size" (unary text::size))
- (bundle.install "char" (binary text::char))
- (bundle.install "clip" (trinary text::clip)))))
-
-(def: bundle::io
- Bundle
- (<| (bundle.prefix "io")
- (|> (is Bundle bundle.empty)
- (bundle.install "log" (unary io::log))
- (bundle.install "error" (unary io::error)))))
-
-(def: .public bundle
- Bundle
- (<| (bundle.prefix "lux")
- (|> bundle::lux
- (dictionary.merged bundle::i64)
- (dictionary.merged bundle::f64)
- (dictionary.merged bundle::text)
- (dictionary.merged bundle::io))))
diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
deleted file mode 100644
index cb1ce6f6c..000000000
--- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux
+++ /dev/null
@@ -1,1248 +0,0 @@
-(.using
- [library
- [lux {"-" Type Label Primitive int char type}
- [ffi {"+" import:}]
- [abstract
- ["[0]" monad {"+" do}]]
- [control
- ["[0]" maybe ("[1]#[0]" functor)]
- ["[0]" exception {"+" exception:}]
- ["[0]" function]
- ["<>" parser ("[1]#[0]" monad)
- ["<[0]>" text]
- ["<[0]>" synthesis {"+" Parser}]]]
- [data
- ["[0]" product]
- ["[0]" text ("[1]#[0]" equivalence)
- ["%" format {"+" format}]]
- [collection
- ["[0]" list ("[1]#[0]" monoid mix monad)]
- ["[0]" dictionary {"+" Dictionary}]
- ["[0]" set {"+" Set}]]]
- [macro
- ["^" pattern]
- ["[0]" template]]
- [math
- [number
- ["n" nat]]]
- [target
- [jvm
- ["[0]" type {"+" Type Typed Argument}
- ["[0]" category {"+" Void Value Return Primitive Object Class Array Var Parameter Method}]
- ["[0]" box]
- ["[0]" reflection]
- ["[0]" signature]
- ["[0]" descriptor]
- ["[0]" parser]]]]
- [tool
- [compiler
- ["[0]" phase ("[1]#[0]" monad)]
- [reference {"+" }
- ["[0]" variable {"+" Variable Register}]]
- [meta
- [archive {"+" Archive}
- ["[0]" unit]]
- ["[0]" cache "_"
- ["[1]" artifact]]]
- [language
- [lux
- [analysis {"+" Environment}]
- ["[0]" synthesis {"+" Synthesis Path %synthesis}]
- ["[0]" generation]
- [phase
- [generation
- [extension {"+" Nullary Unary Binary
- nullary unary binary}]]
- [analysis
- ["[0]A" reference]]
- ["[0]" extension
- ["[0]" bundle]
- [analysis
- ["/" jvm]]]]]]]]]]
- [luxc
- [lang
- [host
- ["$" jvm {"+" Label Inst Def Handler Bundle Operation Phase}
- ["_" inst]
- ["_[0]" def]]]]]
- ["[0]" // "_"
- [common {"+" custom}]
- ["/[1]" //
- ["[1][0]" reference]
- ["[1][0]" function]]])
-
-(template [<name> <category> <parser>]
- [(def: .public <name>
- (Parser (Type <category>))
- (<text>.then <parser> <synthesis>.text))]
-
- [var Var parser.var]
- [class Class parser.class]
- [object Object parser.object]
- [value Value parser.value]
- [return Return parser.return]
- )
-
-(def: signature
- (All (_ a) (-> (Type a) Text))
- (|>> type.signature signature.signature))
-
-(def: descriptor
- (All (_ a) (-> (Type a) Text))
- (|>> type.descriptor descriptor.descriptor))
-
-(exception: .public (not_an_object_array [arrayJT (Type Array)])
- (exception.report
- "JVM Type" (..signature arrayJT)))
-
-(def: .public object_array
- (Parser (Type Object))
- (do <>.monad
- [arrayJT (<text>.then parser.array <synthesis>.text)]
- (case (parser.array? arrayJT)
- {.#Some elementJT}
- (case (parser.object? elementJT)
- {.#Some elementJT}
- (in elementJT)
-
- {.#None}
- (<>.failure (exception.error ..not_an_object_array [arrayJT])))
-
- {.#None}
- (undefined))))
-
-(template [<name> <inst>]
- [(def: <name>
- Inst
- (|>> _.L2I <inst>))]
-
- [L2S _.I2S]
- [L2B _.I2B]
- [L2C _.I2C]
- )
-
-(template [<conversion> <name>]
- [(def: (<name> inputI)
- (Unary Inst)
- (if (same? _.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
- (<| (bundle.prefix "conversion")
- (|> (is 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> [parameterI subjectI])
- (Binary Inst)
- (|>> subjectI
- parameterI
- <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> [referenceI subjectI])
- (Binary Inst)
- (<| _.with_label (function (_ @then))
- _.with_label (function (_ @end))
- (|>> subjectI
- referenceI
- (<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> [referenceI subjectI])
- (Binary Inst)
- (<| _.with_label (function (_ @then))
- _.with_label (function (_ @end))
- (|>> subjectI
- referenceI
- <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
- (<| (bundle.prefix (reflection.reflection reflection.int))
- (|> (is 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
- (<| (bundle.prefix (reflection.reflection reflection.long))
- (|> (is 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
- (<| (bundle.prefix (reflection.reflection reflection.float))
- (|> (is 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
- (<| (bundle.prefix (reflection.reflection reflection.double))
- (|> (is 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
- (<| (bundle.prefix (reflection.reflection reflection.char))
- (|> (is Bundle bundle.empty)
- (bundle.install "=" (binary char::=))
- (bundle.install "<" (binary char::<))
- )))
-
-(def: (primitive_array_length_handler jvm_primitive)
- (-> (Type Primitive) Handler)
- (..custom
- [<synthesis>.any
- (function (_ extension_name generate archive arrayS)
- (do phase.monad
- [arrayI (generate archive arrayS)]
- (in (|>> arrayI
- (_.CHECKCAST (type.array jvm_primitive))
- _.ARRAYLENGTH))))]))
-
-(def: array::length::object
- Handler
- (..custom
- [($_ <>.and ..object_array <synthesis>.any)
- (function (_ extension_name generate archive [elementJT arrayS])
- (do phase.monad
- [arrayI (generate archive arrayS)]
- (in (|>> arrayI
- (_.CHECKCAST (type.array elementJT))
- _.ARRAYLENGTH))))]))
-
-(def: (new_primitive_array_handler jvm_primitive)
- (-> (Type Primitive) Handler)
- (function (_ extension_name generate archive inputs)
- (case inputs
- (pattern (list lengthS))
- (do phase.monad
- [lengthI (generate archive lengthS)]
- (in (|>> lengthI
- (_.array jvm_primitive))))
-
- _
- (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))))
-
-(def: array::new::object
- Handler
- (..custom
- [($_ <>.and ..object <synthesis>.any)
- (function (_ extension_name generate archive [objectJT lengthS])
- (do phase.monad
- [lengthI (generate archive lengthS)]
- (in (|>> lengthI
- (_.ANEWARRAY objectJT)))))]))
-
-(def: (read_primitive_array_handler jvm_primitive loadI)
- (-> (Type Primitive) Inst Handler)
- (function (_ extension_name generate archive inputs)
- (case inputs
- (pattern (list idxS arrayS))
- (do phase.monad
- [arrayI (generate archive arrayS)
- idxI (generate archive idxS)]
- (in (|>> arrayI
- (_.CHECKCAST (type.array jvm_primitive))
- idxI
- loadI)))
-
- _
- (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))))
-
-(def: array::read::object
- Handler
- (..custom
- [($_ <>.and ..object_array <synthesis>.any <synthesis>.any)
- (function (_ extension_name generate archive [elementJT idxS arrayS])
- (do phase.monad
- [arrayI (generate archive arrayS)
- idxI (generate archive idxS)]
- (in (|>> 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
- (pattern (list idxS valueS arrayS))
- (do phase.monad
- [arrayI (generate archive arrayS)
- idxI (generate archive idxS)
- valueI (generate archive valueS)]
- (in (|>> arrayI
- (_.CHECKCAST (type.array jvm_primitive))
- _.DUP
- idxI
- valueI
- storeI)))
-
- _
- (phase.except extension.invalid_syntax [extension_name %synthesis inputs]))))
-
-(def: array::write::object
- Handler
- (..custom
- [($_ <>.and ..object_array <synthesis>.any <synthesis>.any <synthesis>.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)]
- (in (|>> arrayI
- (_.CHECKCAST (type.array elementJT))
- _.DUP
- idxI
- valueI
- _.AASTORE))))]))
-
-(def: array_bundle
- Bundle
- (<| (bundle.prefix "array")
- (|> bundle.empty
- (dictionary.merged (<| (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.merged (<| (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.merged (<| (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.merged (<| (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
- (pattern (list (synthesis.text class)))
- (do phase.monad
- []
- (in (|>> (_.string class)
- (_.INVOKESTATIC $Class "forName" (type.method [(list) (list (type.class "java.lang.String" (list))) $Class (list)])))))
-
- _
- (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))
-
-(def: object::instance?
- Handler
- (..custom
- [($_ <>.and <synthesis>.text <synthesis>.any)
- (function (_ extension_name generate archive [class objectS])
- (do phase.monad
- [objectI (generate archive objectS)]
- (in (|>> objectI
- (_.INSTANCEOF (type.class class (list)))
- (_.wrap type.boolean)))))]))
-
-(def: (object::cast extension_name generate archive inputs)
- Handler
- (case inputs
- (pattern (list (synthesis.text from) (synthesis.text to) valueS))
- (do phase.monad
- [valueI (generate archive valueS)]
- (`` (cond (~~ (template [<object> <primitive>]
- [(and (text#= (reflection.reflection (type.reflection <primitive>))
- from)
- (text#= <object>
- to))
- (in (|>> valueI (_.wrap <primitive>)))
-
- (and (text#= <object>
- from)
- (text#= (reflection.reflection (type.reflection <primitive>))
- to))
- (in (|>> valueI (_.unwrap <primitive>)))]
-
- [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
- (in valueI))))
-
- _
- (phase.except extension.invalid_syntax [extension_name %synthesis inputs])))
-
-(def: object_bundle
- Bundle
- (<| (bundle.prefix "object")
- (|> (is 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.of_list text.hash)))
-
-(def: get::static
- Handler
- (..custom
- [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text)
- (function (_ extension_name generate archive [class field unboxed])
- (do phase.monad
- []
- (case (dictionary.value unboxed ..primitives)
- {.#Some primitive}
- (in (_.GETSTATIC (type.class class (list)) field primitive))
-
- {.#None}
- (in (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))]))
-
-(def: put::static
- Handler
- (..custom
- [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.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.value unboxed ..primitives)
- {.#Some primitive}
- (in (|>> valueI
- (_.PUTSTATIC $class field primitive)
- (_.string synthesis.unit)))
-
- {.#None}
- (in (|>> valueI
- (_.CHECKCAST $class)
- (_.PUTSTATIC $class field $class)
- (_.string synthesis.unit))))))]))
-
-(def: get::virtual
- Handler
- (..custom
- [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.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.value unboxed ..primitives)
- {.#Some primitive}
- (_.GETFIELD $class field primitive)
-
- {.#None}
- (_.GETFIELD $class field (type.class unboxed (list))))]]
- (in (|>> objectI
- (_.CHECKCAST $class)
- getI))))]))
-
-(def: put::virtual
- Handler
- (..custom
- [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any <synthesis>.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.value unboxed ..primitives)
- {.#Some primitive}
- (_.PUTFIELD $class field primitive)
-
- {.#None}
- (let [$unboxed (type.class unboxed (list))]
- (|>> (_.CHECKCAST $unboxed)
- (_.PUTFIELD $class field $unboxed))))]]
- (in (|>> objectI
- (_.CHECKCAST $class)
- _.DUP
- valueI
- putI))))]))
-
-(type: Input
- (Typed Synthesis))
-
-(def: input
- (Parser Input)
- (<synthesis>.tuple (<>.and ..value <synthesis>.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}
- (in [valueT valueI])
-
- {.#Left valueT}
- (in [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 <synthesis>.text ..return (<>.some ..input))
- (function (_ extension_name generate archive [class method outputT inputsTS])
- (do [! phase.monad]
- [inputsTI (monad.each ! (generate_input generate archive) inputsTS)]
- (in (|>> (_.fuse (list#each product.right inputsTI))
- (_.INVOKESTATIC class method (type.method [(list) (list#each product.left inputsTI) outputT (list)]))
- (prepare_output outputT)))))]))
-
-(template [<name> <invoke>]
- [(def: <name>
- Handler
- (..custom
- [($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input))
- (function (_ extension_name generate archive [class method outputT objectS inputsTS])
- (do [! phase.monad]
- [objectI (generate archive objectS)
- inputsTI (monad.each ! (generate_input generate archive) inputsTS)]
- (in (|>> objectI
- (_.CHECKCAST class)
- (_.fuse (list#each product.right inputsTI))
- (<invoke> class method
- (type.method [(list)
- (list#each 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.each ! (generate_input generate archive) inputsTS)]
- (in (|>> (_.NEW class)
- _.DUP
- (_.fuse (list#each product.right inputsTI))
- (_.INVOKESPECIAL class "<init>" (type.method [(list) (list#each product.left inputsTI) type.void (list)]))))))]))
-
-(def: member_bundle
- Bundle
- (<| (bundle.prefix "member")
- (|> (is Bundle bundle.empty)
- (dictionary.merged (<| (bundle.prefix "get")
- (|> (is Bundle bundle.empty)
- (bundle.install "static" get::static)
- (bundle.install "virtual" get::virtual))))
- (dictionary.merged (<| (bundle.prefix "put")
- (|> (is Bundle bundle.empty)
- (bundle.install "static" put::static)
- (bundle.install "virtual" put::virtual))))
- (dictionary.merged (<| (bundle.prefix "invoke")
- (|> (is 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))
- (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any)))
-
-(def: annotation
- (Parser (/.Annotation Synthesis))
- (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter))))
-
-(def: argument
- (Parser Argument)
- (<synthesis>.tuple (<>.and <synthesis>.text ..value)))
-
-(def: .public (hidden_method_body arity body)
- (-> Nat Synthesis Synthesis)
- (case [arity body]
- [0 _] body
- [1 _] body
-
- [2 {synthesis.#Control {synthesis.#Branch {synthesis.#Let _ 2 hidden}}}]
- hidden
-
- [_ {synthesis.#Control {synthesis.#Branch {synthesis.#Case _ path}}}]
- (loop (again [path (is synthesis.Path path)])
- (case path
- (^.or {synthesis.#Pop}
- {synthesis.#Access _}
- {synthesis.#Bind _}
- {synthesis.#Bit_Fork _}
- {synthesis.#I64_Fork _}
- {synthesis.#F64_Fork _}
- {synthesis.#Text_Fork _}
- {synthesis.#Alt _})
- body
-
- {synthesis.#Seq _ next}
- (again next)
-
- {synthesis.#Then hidden}
- hidden))
-
- _
- body))
-
-(def: overriden_method_definition
- (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)])
- (<synthesis>.tuple
- (do <>.monad
- [_ (<synthesis>.this_text /.overriden_tag)
- ownerT ..class
- name <synthesis>.text
- strict_fp? <synthesis>.bit
- annotations (<synthesis>.tuple (<>.some ..annotation))
- vars (<synthesis>.tuple (<>.some ..var))
- self_name <synthesis>.text
- arguments (<synthesis>.tuple (<>.some ..argument))
- returnT ..return
- exceptionsT (<synthesis>.tuple (<>.some ..class))
- [environment _ _ body] (<| (<synthesis>.function 1)
- (<synthesis>.loop (<>.exactly 0 <synthesis>.any))
- <synthesis>.tuple
- (<>.after <synthesis>.any)
- <synthesis>.any)]
- (in [environment
- [ownerT name
- strict_fp? annotations vars
- self_name arguments returnT exceptionsT
- (..hidden_method_body (list.size arguments) body)]]))))
-
-(def: (normalize_path normalize)
- (-> (-> Synthesis Synthesis)
- (-> Path Path))
- (function (again path)
- (case path
- (pattern (synthesis.path/then bodyS))
- (synthesis.path/then (normalize bodyS))
-
- (^.template [<tag>]
- [(pattern {<tag> leftP rightP})
- {<tag> (again leftP) (again rightP)}])
- ([synthesis.#Alt]
- [synthesis.#Seq])
-
- (^.template [<tag>]
- [(pattern {<tag> _})
- path])
- ([synthesis.#Pop]
- [synthesis.#Bind]
- [synthesis.#Access])
-
- {synthesis.#Bit_Fork when then else}
- {synthesis.#Bit_Fork when (again then) (maybe#each again else)}
-
- (^.template [<tag>]
- [{<tag> [[test then] elses]}
- {<tag> [[test (again then)]
- (list#each (function (_ [else_test else_then])
- [else_test (again else_then)])
- elses)]}])
- ([synthesis.#I64_Fork]
- [synthesis.#F64_Fork]
- [synthesis.#Text_Fork])
- )))
-
-(type: Mapping
- (Dictionary Synthesis Variable))
-
-(def: (local_mapping global_mapping)
- (-> Mapping (Environment Synthesis) Mapping)
- (|>> list.enumeration
- (list#each (function (_ [foreign_id capture])
- [(synthesis.variable/foreign foreign_id)
- (|> global_mapping
- (dictionary.value capture)
- maybe.trusted)]))
- (dictionary.of_list synthesis.hash)))
-
-(def: (init_mapping global_mapping)
- (-> Mapping (Environment Synthesis) Mapping)
- (|>> list.enumeration
- (list#each (function (_ [id capture])
- [(synthesis.variable/foreign id)
- {variable.#Local (++ id)}]))
- (dictionary.of_list synthesis.hash)))
-
-(def: (normalize_method_body mapping)
- (-> Mapping Synthesis Synthesis)
- (function (again body)
- (case body
- (^.template [<tag>]
- [(pattern <tag>)
- body])
- ([{synthesis.#Primitive _}]
- [(synthesis.constant _)])
-
- (pattern (synthesis.variant [lefts right? sub]))
- (synthesis.variant [lefts right? (again sub)])
-
- (pattern (synthesis.tuple members))
- (synthesis.tuple (list#each again members))
-
- (pattern (synthesis.variable var))
- (|> mapping
- (dictionary.value body)
- (maybe.else var)
- synthesis.variable)
-
- (pattern (synthesis.branch/case [inputS pathS]))
- (synthesis.branch/case [(again inputS) (normalize_path again pathS)])
-
- (pattern (synthesis.branch/exec [this that]))
- (synthesis.branch/exec [(again this) (again that)])
-
- (pattern (synthesis.branch/let [inputS register outputS]))
- (synthesis.branch/let [(again inputS) register (again outputS)])
-
- (pattern (synthesis.branch/if [testS thenS elseS]))
- (synthesis.branch/if [(again testS) (again thenS) (again elseS)])
-
- (pattern (synthesis.branch/get [path recordS]))
- (synthesis.branch/get [path (again recordS)])
-
- (pattern (synthesis.loop/scope [offset initsS+ bodyS]))
- (synthesis.loop/scope [offset (list#each again initsS+) (again bodyS)])
-
- (pattern (synthesis.loop/again updatesS+))
- (synthesis.loop/again (list#each again updatesS+))
-
- (pattern (synthesis.function/abstraction [environment arity bodyS]))
- (synthesis.function/abstraction [(list#each (function (_ captured)
- (case captured
- (pattern (synthesis.variable var))
- (|> mapping
- (dictionary.value captured)
- (maybe.else var)
- synthesis.variable)
-
- _
- captured))
- environment)
- arity
- bodyS])
-
- (pattern (synthesis.function/apply [functionS inputsS+]))
- (synthesis.function/apply [(again functionS) (list#each again inputsS+)])
-
- {synthesis.#Extension [name inputsS+]}
- {synthesis.#Extension [name (list#each again inputsS+)]})))
-
-(def: $Object
- (type.class "java.lang.Object" (list)))
-
-(def: (anonymous_init_method env inputsTI)
- (-> (Environment Synthesis) (List (Typed Inst)) (Type Method))
- (type.method [(list)
- (list.repeated (n.+ (list.size inputsTI) (list.size env)) $Object)
- type.void
- (list)]))
-
-(def: (with_anonymous_init class env super_class inputsTI)
- (-> (Type Class) (Environment Synthesis) (Type Class) (List (Typed Inst)) Def)
- (let [inputs_offset (list.size inputsTI)
- inputs! (|> inputsTI
- list.enumeration
- (list#each (function (_ [register [type term]])
- (let [then! (case (type.primitive? type)
- {.#Right type}
- (_.unwrap type)
-
- {.#Left type}
- (_.CHECKCAST type))]
- (|>> (_.ALOAD (++ register))
- then!))))
- _.fuse)
- store_capturedI (|> env
- list.size
- list.indices
- (list#each (.function (_ register)
- (|>> (_.ALOAD 0)
- (_.ALOAD (n.+ inputs_offset (++ register)))
- (_.PUTFIELD class (///reference.foreign_name register) $Object))))
- _.fuse)]
- (_def.method {$.#Public} $.noneM "<init>" (anonymous_init_method env inputsTI)
- (|>> (_.ALOAD 0)
- inputs!
- (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list#each product.left inputsTI) type.void (list)]))
- store_capturedI
- _.RETURN))))
-
-(def: (anonymous_instance generate archive class env inputsTI)
- (-> Phase Archive (Type Class) (Environment Synthesis) (List (Typed Inst)) (Operation Inst))
- (do [! phase.monad]
- [captureI+ (monad.each ! (generate archive) env)]
- (in (|>> (_.NEW class)
- _.DUP
- ((_.fuse (list#each product.right inputsTI)))
- ((_.fuse captureI+))
- (_.INVOKESPECIAL class "<init>" (anonymous_init_method env inputsTI))))))
-
-(def: (prepare_argument lux_register argumentT jvm_register)
- (-> Register (Type Value) Register [Register Inst])
- (case (type.primitive? argumentT)
- {.#Left argumentT}
- [(n.+ 1 jvm_register)
- (if (n.= lux_register jvm_register)
- (|>>)
- (|>> (_.ALOAD jvm_register)
- (_.ASTORE lux_register)))]
-
- {.#Right argumentT}
- (template.let [(wrap_primitive <shift> <load> <type>)
- [[(n.+ <shift> jvm_register)
- (|>> (<load> jvm_register)
- (_.wrap <type>)
- (_.ASTORE lux_register))]]]
- (`` (cond (~~ (template [<shift> <load> <type>]
- [(# type.equivalence = <type> argumentT)
- (wrap_primitive <shift> <load> <type>)]
-
- [1 _.ILOAD type.boolean]
- [1 _.ILOAD type.byte]
- [1 _.ILOAD type.short]
- [1 _.ILOAD type.int]
- [1 _.ILOAD type.char]
- [1 _.FLOAD type.float]
- [2 _.LLOAD type.long]))
-
- ... (# type.equivalence = type.double argumentT)
- (wrap_primitive 2 _.DLOAD type.double))))))
-
-(def: .public (prepare_arguments offset types)
- (-> Nat (List (Type Value)) Inst)
- (|> types
- list.enumeration
- (list#mix (function (_ [lux_register type] [jvm_register before])
- (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)]
- [jvm_register' (|>> before after)]))
- (is [Register Inst] [offset (|>>)]))
- product.right))
-
-(def: .public (returnI returnT)
- (-> (Type Return) Inst)
- (case (type.void? returnT)
- {.#Right returnT}
- _.RETURN
-
- {.#Left returnT}
- (case (type.primitive? returnT)
- {.#Left returnT}
- (case (type.class? returnT)
- {.#Some class_name}
- (|>> (_.CHECKCAST returnT)
- _.ARETURN)
-
- {.#None}
- _.ARETURN)
-
- {.#Right returnT}
- (template.let [(unwrap_primitive <return> <type>)
- [(|>> (_.unwrap <type>)
- <return>)]]
- (`` (cond (~~ (template [<return> <type>]
- [(# type.equivalence = <type> returnT)
- (unwrap_primitive <return> <type>)]
-
- [_.IRETURN type.boolean]
- [_.IRETURN type.byte]
- [_.IRETURN type.short]
- [_.IRETURN type.int]
- [_.IRETURN type.char]
- [_.FRETURN type.float]
- [_.LRETURN type.long]))
-
- ... (# type.equivalence = type.double returnT)
- (unwrap_primitive _.DRETURN type.double)))))))
-
-(def: (method_dependencies archive method)
- (-> Archive (/.Overriden_Method Synthesis) (Operation (Set unit.ID)))
- (let [[_super _name _strict_fp? _annotations
- _t_vars _this _arguments _return _exceptions
- bodyS] method]
- (cache.dependencies archive bodyS)))
-
-(def: class::anonymous
- Handler
- (..custom
- [($_ <>.and
- ..class
- (<synthesis>.tuple (<>.some ..class))
- (<synthesis>.tuple (<>.some ..input))
- (<synthesis>.tuple (<>.some ..overriden_method_definition)))
- (function (_ extension_name generate archive [super_class
- super_interfaces
- inputsTS
- overriden_methods])
- (do [! phase.monad]
- [all_input_dependencies (monad.each ! (|>> product.right (cache.dependencies archive)) inputsTS)
- all_closure_dependencies (|> overriden_methods
- (list#each product.left)
- list.together
- (monad.each ! (cache.dependencies archive)))
- all_method_dependencies (monad.each ! (|>> product.right (method_dependencies archive)) overriden_methods)
- .let [all_dependencies (cache.all ($_ list#composite
- all_input_dependencies
- all_closure_dependencies
- all_method_dependencies))]
- [context _] (generation.with_new_context
- archive
- all_dependencies
- (in []))
- .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#each product.left)
- ... Combine them.
- list#conjoint
- ... Remove duplicates.
- (set.of_list synthesis.hash)
- set.list)
- global_mapping (|> total_environment
- ... Give them names as "foreign" variables.
- list.enumeration
- (list#each (function (_ [id capture])
- [capture {variable.#Foreign id}]))
- (dictionary.of_list synthesis.hash))
- normalized_methods (list#each (function (_ [environment
- [ownerT name
- strict_fp? annotations vars
- self_name arguments returnT exceptionsT
- body]])
- [ownerT name
- strict_fp? annotations vars
- self_name arguments returnT exceptionsT
- (normalize_method_body (..local_mapping global_mapping environment)
- body)])
- overriden_methods)
- inputsTS (let [mapping (..init_mapping global_mapping total_environment)]
- (list#each (function (_ [type term])
- [type (normalize_method_body mapping term)])
- inputsTS))]
- inputsTI (generation.with_context artifact_id
- (monad.each ! (generate_input generate archive) inputsTS))
- method_definitions (|> normalized_methods
- (monad.each ! (function (_ [ownerT name
- strict_fp? annotations varsT
- self_name arguments returnT exceptionsT
- bodyS])
- (do !
- [bodyG (generation.with_context artifact_id
- (generate archive bodyS))
- .let [argumentsT (list#each product.right arguments)]]
- (in (_def.method {$.#Public}
- (if strict_fp?
- ($_ $.++M $.finalM $.strictM)
- $.finalM)
- name
- (type.method [varsT argumentsT returnT exceptionsT])
- (|>> (prepare_arguments 1 argumentsT)
- bodyG
- (returnI returnT)))))))
- (# ! each _def.fuse))
- .let [directive [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))]]
- _ (generation.execute! directive)
- _ (generation.save! artifact_id {.#None} directive)]
- (..anonymous_instance generate archive class total_environment inputsTI)))]))
-
-(def: class_bundle
- Bundle
- (<| (bundle.prefix "class")
- (|> (is Bundle bundle.empty)
- (bundle.install "anonymous" class::anonymous)
- )))
-
-(def: .public bundle
- Bundle
- (<| (bundle.prefix "jvm")
- (|> ..conversion_bundle
- (dictionary.merged ..int_bundle)
- (dictionary.merged ..long_bundle)
- (dictionary.merged ..float_bundle)
- (dictionary.merged ..double_bundle)
- (dictionary.merged ..char_bundle)
- (dictionary.merged ..array_bundle)
- (dictionary.merged ..object_bundle)
- (dictionary.merged ..member_bundle)
- (dictionary.merged ..class_bundle)
- )))