From 60daee098f92a44c3b404a9f5801f2e8126ad650 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 5 Apr 2022 18:32:42 -0400 Subject: No longer depending on the ASM library for JVM bytecode generation. --- .../luxc/lang/translation/jvm/extension/common.lux | 359 ------ .../luxc/lang/translation/jvm/extension/host.lux | 1248 -------------------- 2 files changed, 1607 deletions(-) delete mode 100644 lux-jvm/source/luxc/lang/translation/jvm/extension/common.lux delete mode 100644 lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux (limited to 'lux-jvm/source/luxc/lang/translation/jvm/extension') 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 - ["" 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 (.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 - .any - .any - (<>.some (.tuple ($_ <>.and - (.tuple (<>.many .i64)) - .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 [ ] - [(def: ( [maskI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - maskI (_.unwrap type.long) - (_.wrap type.long)))] - - [i64::and _.LAND] - [i64::or _.LOR] - [i64::xor _.LXOR] - ) - -(template [ ] - [(def: ( [shiftI inputI]) - (Binary Inst) - (|>> inputI (_.unwrap type.long) - shiftI jvm_intI - - (_.wrap type.long)))] - - [i64::left_shift _.LSHL] - [i64::right_shift _.LUSHR] - ) - -(template [ ] - [(def: ( [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap ) - paramI (_.unwrap ) - - (_.wrap )))] - - [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 [ ] - [(template [ ] - [(def: ( [paramI subjectI]) - (Binary Inst) - (|>> subjectI (_.unwrap ) - paramI (_.unwrap ) - - (_.int ) - (predicateI _.IF_ICMPEQ)))] - - [ +0] - [ -1])] - - [i64::= i64::< type.long _.LCMP] - [f64::= f64::< type.double _.DCMPG] - ) - -(template [ ] - [(def: ( inputI) - (Unary Inst) - (|>> inputI ))] - - [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 [ ] - [(def: ( [paramI subjectI]) - (Binary Inst) - (|>> subjectI - paramI - ))] - - [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 "" 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 [ ] - [(def: .public - (Parser (Type )) - (.then .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 (.then parser.array .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 [ ] - [(def: - Inst - (|>> _.L2I ))] - - [L2S _.I2S] - [L2B _.I2B] - [L2C _.I2C] - ) - -(template [ ] - [(def: ( inputI) - (Unary Inst) - (if (same? _.NOP ) - inputI - (|>> inputI - )))] - - [_.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 [ ] - [(def: ( [parameterI subjectI]) - (Binary Inst) - (|>> subjectI - parameterI - ))] - - [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 [ ] - [(def: ( [referenceI subjectI]) - (Binary Inst) - (<| _.with_label (function (_ @then)) - _.with_label (function (_ @end)) - (|>> subjectI - referenceI - ( @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [int::= _.IF_ICMPEQ] - [int::< _.IF_ICMPLT] - - [char::= _.IF_ICMPEQ] - [char::< _.IF_ICMPLT] - ) - -(template [ ] - [(def: ( [referenceI subjectI]) - (Binary Inst) - (<| _.with_label (function (_ @then)) - _.with_label (function (_ @end)) - (|>> subjectI - referenceI - - (_.int ) - (_.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 - [.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 .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 .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 .any .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 .any .any .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 .text .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 [ ] - [(and (text#= (reflection.reflection (type.reflection )) - from) - (text#= - to)) - (in (|>> valueI (_.wrap ))) - - (and (text#= - from) - (text#= (reflection.reflection (type.reflection )) - to)) - (in (|>> valueI (_.unwrap )))] - - [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 .text .text .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 .text .text .text .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 .text .text .text .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 .text .text .text .any .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) - (.tuple (<>.and ..value .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 .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 [ ] - [(def: - Handler - (..custom - [($_ <>.and ..class .text ..return .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)) - ( 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 "" (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)) - (.tuple (<>.and .text .any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (.tuple (<>.and .text (<>.some ..annotation_parameter)))) - -(def: argument - (Parser Argument) - (.tuple (<>.and .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)]) - (.tuple - (do <>.monad - [_ (.this_text /.overriden_tag) - ownerT ..class - name .text - strict_fp? .bit - annotations (.tuple (<>.some ..annotation)) - vars (.tuple (<>.some ..var)) - self_name .text - arguments (.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (.tuple (<>.some ..class)) - [environment _ _ body] (<| (.function 1) - (.loop (<>.exactly 0 .any)) - .tuple - (<>.after .any) - .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 [] - [(pattern { leftP rightP}) - { (again leftP) (again rightP)}]) - ([synthesis.#Alt] - [synthesis.#Seq]) - - (^.template [] - [(pattern { _}) - path]) - ([synthesis.#Pop] - [synthesis.#Bind] - [synthesis.#Access]) - - {synthesis.#Bit_Fork when then else} - {synthesis.#Bit_Fork when (again then) (maybe#each again else)} - - (^.template [] - [{ [[test then] elses]} - { [[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 [] - [(pattern ) - 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 "" (anonymous_init_method env inputsTI) - (|>> (_.ALOAD 0) - inputs! - (_.INVOKESPECIAL super_class "" (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 "" (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 ) - [[(n.+ jvm_register) - (|>> ( jvm_register) - (_.wrap ) - (_.ASTORE lux_register))]]] - (`` (cond (~~ (template [ ] - [(# type.equivalence = argumentT) - (wrap_primitive )] - - [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 ) - [(|>> (_.unwrap ) - )]] - (`` (cond (~~ (template [ ] - [(# type.equivalence = returnT) - (unwrap_primitive )] - - [_.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 - (.tuple (<>.some ..class)) - (.tuple (<>.some ..input)) - (.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) - ))) -- cgit v1.2.3