From 4deb3fc67c9c0cbf04ec8ba7c21b1558b0b415cf Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 30 Dec 2019 03:14:54 -0400 Subject: Re-located generation extensions for JVM. --- .../tool/compiler/phase/extension/generation.lux | 10 - .../compiler/phase/extension/generation/jvm.lux | 19 + .../phase/extension/generation/jvm/common.lux | 450 ++++++++ .../phase/extension/generation/jvm/host.lux | 1088 ++++++++++++++++++++ .../compiler/phase/generation/jvm/extension.lux | 17 - .../phase/generation/jvm/extension/common.lux | 448 -------- .../phase/generation/jvm/extension/host.lux | 1086 ------------------- 7 files changed, 1557 insertions(+), 1561 deletions(-) delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation/jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/common.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/tool/compiler/phase/extension/generation.lux b/stdlib/source/lux/tool/compiler/phase/extension/generation.lux deleted file mode 100644 index 467adbf35..000000000 --- a/stdlib/source/lux/tool/compiler/phase/extension/generation.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #*] - [// - ["." bundle] - [// - [generation (#+ Bundle)]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm.lux new file mode 100644 index 000000000..93816d128 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm.lux @@ -0,0 +1,19 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + ["." / #_ + ["#." common] + ["#." host] + [//// + [generation + [jvm + [runtime (#+ Bundle)]]]]]) + +(def: #export bundle + Bundle + ($_ dictionary.merge + /common.bundle + /host.bundle + )) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/common.lux new file mode 100644 index 000000000..c666c1df5 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/common.lux @@ -0,0 +1,450 @@ +(.module: + [lux (#- Type) + [host (#+ import:)] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["" synthesis (#+ Parser)]]] + [data + ["." product] + [number + ["." i32] + ["f" frac]] + [collection + ["." list ("#@." monad)] + ["." dictionary]]] + [target + [jvm + ["_" bytecode (#+ Label Bytecode) ("#@." monad)] + [encoding + ["." signed (#+ S4)]] + ["." type (#+ Type) + [category (#+ Primitive Class)]]]]] + [///// + [generation + ["///" jvm #_ + ["#." value] + ["#." runtime (#+ Operation Phase Bundle Handler)] + ["#." function #_ + ["#" abstract]] + ["//#" /// + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] + [extension + ["#extension" /] + ["#." bundle]] + ["/#" // + ["#." synthesis (#+ Synthesis %synthesis)]]]]]]) + +(def: #export (custom [parser handler]) + (All [s] + (-> [(Parser s) + (-> Text Phase s (Operation (Bytecode Any)))] + Handler)) + (function (_ extension-name phase input) + (case (.run parser input) + (#try.Success input') + (handler extension-name phase input') + + (#try.Failure error) + (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input])))) + +(def: $Boolean (type.class "java.lang.Boolean" (list))) +(def: $Double (type.class "java.lang.Double" (list))) +(def: $Character (type.class "java.lang.Character" (list))) +(def: $String (type.class "java.lang.String" (list))) +(def: $CharSequence (type.class "java.lang.CharSequence" (list))) +(def: $Object (type.class "java.lang.Object" (list))) +(def: $PrintStream (type.class "java.io.PrintStream" (list))) +(def: $System (type.class "java.lang.System" (list))) +(def: $Error (type.class "java.lang.Error" (list))) + +(def: lux-int + (Bytecode Any) + ($_ _.compose + _.i2l + (///value.wrap type.long))) + +(def: jvm-int + (Bytecode Any) + ($_ _.compose + (///value.unwrap type.long) + _.l2i)) + +(def: ensure-string + (Bytecode Any) + (_.checkcast $String)) + +(def: (predicate bytecode) + (-> (-> Label (Bytecode Any)) + (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + (bytecode @then) + (_.getstatic $Boolean "FALSE" $Boolean) + (_.goto @end) + (_.set-label @then) + (_.getstatic $Boolean "TRUE" $Boolean) + (_.set-label @end) + ))) + +## 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 [inputS elseS conditionalsS]) + (do /////.monad + [@end ///runtime.forge-label + inputG (phase inputS) + elseG (phase elseS) + conditionalsG+ (: (Operation (List [(List [S4 Label]) + (Bytecode Any)])) + (monad.map @ (function (_ [chars branch]) + (do @ + [branchG (phase branch) + @branch ///runtime.forge-label] + (wrap [(list@map (function (_ char) + [(try.assume (signed.s4 (.int char))) @branch]) + chars) + ($_ _.compose + (_.set-label @branch) + branchG + (_.goto @end))]))) + conditionalsS)) + #let [table (|> conditionalsG+ + (list@map product.left) + list@join) + conditionalsG (|> conditionalsG+ + (list@map product.right) + (monad.seq _.monad))]] + (wrap (do _.monad + [@else _.new-label] + ($_ _.compose + inputG (///value.unwrap type.long) _.l2i + (_.lookupswitch @else table) + conditionalsG + (_.set-label @else) + elseG + (_.set-label @end) + )))))])) + +(def: (lux::is [referenceG sampleG]) + (Binary (Bytecode Any)) + ($_ _.compose + referenceG + sampleG + (..predicate _.if-acmpeq))) + +(def: (lux::try riskyG) + (Unary (Bytecode Any)) + ($_ _.compose + riskyG + (_.checkcast ///function.class) + ///runtime.try)) + +(def: bundle::lux + Bundle + (|> (: Bundle /////bundle.empty) + (/////bundle.install "syntax char case!" ..lux::syntax-char-case!) + (/////bundle.install "is" (binary ..lux::is)) + (/////bundle.install "try" (unary ..lux::try)))) + +(template [ ] + [(def: ( [maskG inputG]) + (Binary (Bytecode Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + maskG (///value.unwrap type.long) + (///value.wrap type.long)))] + + [i64::and _.land] + [i64::or _.lor] + [i64::xor _.lxor] + ) + +(template [ ] + [(def: ( [shiftG inputG]) + (Binary (Bytecode Any)) + ($_ _.compose + inputG (///value.unwrap type.long) + shiftG ..jvm-int + (///value.wrap type.long)))] + + [i64::left-shift _.lshl] + [i64::arithmetic-right-shift _.lshr] + [i64::logical-right-shift _.lushr] + ) + +(import: #long java/lang/Double + (#static MIN_VALUE double) + (#static MAX_VALUE double)) + +(template [ ] + [(def: ( _) + (Nullary (Bytecode Any)) + ($_ _.compose + (_.double ) + (///value.wrap type.double)))] + + [f64::smallest (java/lang/Double::MIN_VALUE)] + [f64::min (f.* -1.0 (java/lang/Double::MAX_VALUE))] + [f64::max (java/lang/Double::MAX_VALUE)] + ) + +(template [ ] + [(def: ( [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG (///value.unwrap ) + paramG (///value.unwrap ) + (///value.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: ( [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG (///value.unwrap ) + paramG (///value.unwrap ) + + + (..predicate _.if-icmpeq)))] + + [ _.iconst-0] + [ _.iconst-m1])] + + [i64::= i64::< type.long _.lcmp] + [f64::= f64::< type.double _.dcmpg] + ) + +(def: (to-string class from) + (-> (Type Class) (Type Primitive) (Bytecode Any)) + (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) + +(template [ ] + [(def: ( inputG) + (Unary (Bytecode Any)) + ($_ _.compose + inputG + + ))] + + [i64::f64 + (///value.unwrap type.long) + ($_ _.compose + _.l2d + (///value.wrap type.double))] + + [i64::char + (///value.unwrap type.long) + ($_ _.compose + _.l2i + _.i2c + (..to-string ..$Character type.char))] + + [f64::i64 + (///value.unwrap type.double) + ($_ _.compose + _.d2l + (///value.wrap type.long))] + + [f64::encode + (///value.unwrap type.double) + (..to-string ..$Double type.double)] + + [f64::decode + ..ensure-string + ///runtime.decode-frac] + ) + +(def: bundle::i64 + Bundle + (<| (/////bundle.prefix "i64") + (|> (: 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 "logical-right-shift" (binary ..i64::logical-right-shift)) + (/////bundle.install "arithmetic-right-shift" (binary ..i64::arithmetic-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") + (|> (: 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 "smallest" (nullary ..f64::smallest)) + (/////bundle.install "min" (nullary ..f64::min)) + (/////bundle.install "max" (nullary ..f64::max)) + (/////bundle.install "i64" (unary ..f64::i64)) + (/////bundle.install "encode" (unary ..f64::encode)) + (/////bundle.install "decode" (unary ..f64::decode))))) + +(def: (text::size inputG) + (Unary (Bytecode Any)) + ($_ _.compose + inputG + ..ensure-string + (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) + ..lux-int)) + +(def: no-op (Bytecode Any) (_@wrap [])) + +(template [ ] + [(def: ( [paramG subjectG]) + (Binary (Bytecode Any)) + ($_ _.compose + subjectG + paramG + ))] + + [text::= ..no-op ..no-op + (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) + (///value.wrap type.boolean)] + [text::< ..ensure-string ..ensure-string + (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) + (..predicate _.iflt)] + [text::char ..ensure-string ..jvm-int + (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) + ..lux-int] + ) + +(def: (text::concat [leftG rightG]) + (Binary (Bytecode Any)) + ($_ _.compose + leftG ..ensure-string + rightG ..ensure-string + (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) + +(def: (text::clip [startG endG subjectG]) + (Trinary (Bytecode Any)) + ($_ _.compose + subjectG ..ensure-string + startG ..jvm-int + endG ..jvm-int + (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)])))) + +(def: index-method (type.method [(list ..$String type.int) type.int (list)])) +(def: (text::index [startG partG textG]) + (Trinary (Bytecode Any)) + (do _.monad + [@not-found _.new-label + @end _.new-label] + ($_ _.compose + textG ..ensure-string + partG ..ensure-string + startG ..jvm-int + (_.invokevirtual ..$String "indexOf" index-method) + _.dup + _.iconst-m1 + (_.if-icmpeq @not-found) + ..lux-int + ///runtime.some-injection + (_.goto @end) + (_.set-label @not-found) + _.pop + ///runtime.none-injection + (_.set-label @end)))) + +(def: bundle::text + Bundle + (<| (/////bundle.prefix "text") + (|> (: 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: string-method (type.method [(list ..$String) type.void (list)])) +(def: (io::log messageG) + (Unary (Bytecode Any)) + ($_ _.compose + (_.getstatic ..$System "out" ..$PrintStream) + messageG + ..ensure-string + (_.invokevirtual ..$PrintStream "println" ..string-method) + ///runtime.unit)) + +(def: (io::error messageG) + (Unary (Bytecode Any)) + ($_ _.compose + (_.new ..$Error) + _.dup + messageG + ..ensure-string + (_.invokespecial ..$Error "" ..string-method) + _.athrow)) + +(def: exit-method (type.method [(list type.int) type.void (list)])) +(def: (io::exit codeG) + (Unary (Bytecode Any)) + ($_ _.compose + codeG ..jvm-int + (_.invokestatic ..$System "exit" ..exit-method) + _.aconst-null)) + +(def: time-method (type.method [(list) type.long (list)])) +(def: (io::current-time _) + (Nullary (Bytecode Any)) + ($_ _.compose + (_.invokestatic ..$System "currentTimeMillis" ..time-method) + (///value.wrap type.long))) + +(def: bundle::io + Bundle + (<| (/////bundle.prefix "io") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "log" (unary ..io::log)) + (/////bundle.install "error" (unary ..io::error)) + (/////bundle.install "exit" (unary ..io::exit)) + (/////bundle.install "current-time" (nullary ..io::current-time))))) + +(def: #export bundle + Bundle + (<| (/////bundle.prefix "lux") + (|> bundle::lux + (dictionary.merge ..bundle::i64) + (dictionary.merge ..bundle::f64) + (dictionary.merge ..bundle::text) + (dictionary.merge ..bundle::io)))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/host.lux new file mode 100644 index 000000000..6c8253c12 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/generation/jvm/host.lux @@ -0,0 +1,1088 @@ +(.module: + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["" text] + ["" synthesis (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text ("#@." equivalence)] + [number + ["." i32]] + [collection + ["." list ("#@." monad)] + ["." dictionary (#+ Dictionary)] + ["." set] + ["." row]] + ["." format #_ + ["#" binary]]] + [target + [jvm + ["." version] + ["." modifier ("#@." monoid)] + ["." method (#+ Method)] + ["." class (#+ Class)] + [constant + [pool (#+ Resource)]] + [encoding + ["." name]] + ["_" bytecode (#+ Label Bytecode) ("#@." monad) + ["__" instruction (#+ Primitive-Array-Type)]] + ["." type (#+ Type Typed Argument) + ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)] + ["." box] + ["." reflection] + ["." signature] + ["." parser]]]]] + [// + [common (#+ custom)] + [//// + [generation + ["///" jvm + [runtime (#+ Operation Bundle Handler)] + ["#." reference] + [function + [field + [variable + ["." foreign]]]] + ["//#" /// + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] + [extension + ["#." bundle] + [analysis + ["/" jvm]]] + ["/#" // + ["#." reference (#+ Variable)] + [analysis (#+ Environment)] + ["#." synthesis (#+ Synthesis Path %synthesis)] + ["#." generation]]]]]]]) + +(template [ <0> <1>] + [(def: + (Bytecode Any) + ($_ _.compose + <0> + <1>))] + + [l2s _.l2i _.i2s] + [l2b _.l2i _.i2b] + [l2c _.l2i _.i2c] + ) + +(template [ ] + [(def: ( inputG) + (Unary (Bytecode Any)) + (if (is? _.nop ) + inputG + ($_ _.compose + inputG + )))] + + [_.d2f conversion::double-to-float] + [_.d2i conversion::double-to-int] + [_.d2l conversion::double-to-long] + [_.f2d conversion::float-to-double] + [_.f2i conversion::float-to-int] + [_.f2l conversion::float-to-long] + [_.i2b conversion::int-to-byte] + [_.i2c conversion::int-to-char] + [_.i2d conversion::int-to-double] + [_.i2f conversion::int-to-float] + [_.i2l conversion::int-to-long] + [_.i2s conversion::int-to-short] + [_.l2d conversion::long-to-double] + [_.l2f conversion::long-to-float] + [_.l2i conversion::long-to-int] + [..l2s conversion::long-to-short] + [..l2b conversion::long-to-byte] + [..l2c conversion::long-to-char] + [_.i2b conversion::char-to-byte] + [_.i2s conversion::char-to-short] + [_.nop conversion::char-to-int] + [_.i2l conversion::char-to-long] + [_.i2l conversion::byte-to-long] + [_.i2l conversion::short-to-long] + ) + +(def: bundle::conversion + Bundle + (<| (/////bundle.prefix "conversion") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "double-to-float" (unary conversion::double-to-float)) + (/////bundle.install "double-to-int" (unary conversion::double-to-int)) + (/////bundle.install "double-to-long" (unary conversion::double-to-long)) + (/////bundle.install "float-to-double" (unary conversion::float-to-double)) + (/////bundle.install "float-to-int" (unary conversion::float-to-int)) + (/////bundle.install "float-to-long" (unary conversion::float-to-long)) + (/////bundle.install "int-to-byte" (unary conversion::int-to-byte)) + (/////bundle.install "int-to-char" (unary conversion::int-to-char)) + (/////bundle.install "int-to-double" (unary conversion::int-to-double)) + (/////bundle.install "int-to-float" (unary conversion::int-to-float)) + (/////bundle.install "int-to-long" (unary conversion::int-to-long)) + (/////bundle.install "int-to-short" (unary conversion::int-to-short)) + (/////bundle.install "long-to-double" (unary conversion::long-to-double)) + (/////bundle.install "long-to-float" (unary conversion::long-to-float)) + (/////bundle.install "long-to-int" (unary conversion::long-to-int)) + (/////bundle.install "long-to-short" (unary conversion::long-to-short)) + (/////bundle.install "long-to-byte" (unary conversion::long-to-byte)) + (/////bundle.install "long-to-char" (unary conversion::long-to-char)) + (/////bundle.install "char-to-byte" (unary conversion::char-to-byte)) + (/////bundle.install "char-to-short" (unary conversion::char-to-short)) + (/////bundle.install "char-to-int" (unary conversion::char-to-int)) + (/////bundle.install "char-to-long" (unary conversion::char-to-long)) + (/////bundle.install "byte-to-long" (unary conversion::byte-to-long)) + (/////bundle.install "short-to-long" (unary conversion::short-to-long)) + ))) + +(template [ ] + [(def: ( [xG yG]) + (Binary (Bytecode Any)) + ($_ _.compose + xG + yG + ))] + + [int::+ _.iadd] + [int::- _.isub] + [int::* _.imul] + [int::/ _.idiv] + [int::% _.irem] + [int::and _.iand] + [int::or _.ior] + [int::xor _.ixor] + [int::shl _.ishl] + [int::shr _.ishr] + [int::ushr _.iushr] + + [long::+ _.ladd] + [long::- _.lsub] + [long::* _.lmul] + [long::/ _.ldiv] + [long::% _.lrem] + [long::and _.land] + [long::or _.lor] + [long::xor _.lxor] + [long::shl _.lshl] + [long::shr _.lshr] + [long::ushr _.lushr] + + [float::+ _.fadd] + [float::- _.fsub] + [float::* _.fmul] + [float::/ _.fdiv] + [float::% _.frem] + + [double::+ _.dadd] + [double::- _.dsub] + [double::* _.dmul] + [double::/ _.ddiv] + [double::% _.drem] + ) + +(def: $Boolean (type.class box.boolean (list))) +(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean)) +(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean)) + +(template [ ] + [(def: ( [xG yG]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + xG + yG + ( @then) + falseG + (_.goto @end) + (_.set-label @then) + trueG + (_.set-label @end))))] + + [int::= _.if-icmpeq] + [int::< _.if-icmplt] + + [char::= _.if-icmpeq] + [char::< _.if-icmplt] + ) + +(template [ ] + [(def: ( [xG yG]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + xG + yG + + (_.int (i32.i32 (.i64 ))) + (_.if-icmpeq @then) + falseG + (_.goto @end) + (_.set-label @then) + trueG + (_.set-label @end))))] + + [long::= _.lcmp +0] + [long::< _.lcmp -1] + + [float::= _.fcmpg +0] + [float::< _.fcmpg -1] + + [double::= _.dcmpg +0] + [double::< _.dcmpg -1] + ) + +(def: bundle::int + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.int)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary int::+)) + (/////bundle.install "-" (binary int::-)) + (/////bundle.install "*" (binary int::*)) + (/////bundle.install "/" (binary int::/)) + (/////bundle.install "%" (binary int::%)) + (/////bundle.install "=" (binary int::=)) + (/////bundle.install "<" (binary int::<)) + (/////bundle.install "and" (binary int::and)) + (/////bundle.install "or" (binary int::or)) + (/////bundle.install "xor" (binary int::xor)) + (/////bundle.install "shl" (binary int::shl)) + (/////bundle.install "shr" (binary int::shr)) + (/////bundle.install "ushr" (binary int::ushr)) + ))) + +(def: bundle::long + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.long)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary long::+)) + (/////bundle.install "-" (binary long::-)) + (/////bundle.install "*" (binary long::*)) + (/////bundle.install "/" (binary long::/)) + (/////bundle.install "%" (binary long::%)) + (/////bundle.install "=" (binary long::=)) + (/////bundle.install "<" (binary long::<)) + (/////bundle.install "and" (binary long::and)) + (/////bundle.install "or" (binary long::or)) + (/////bundle.install "xor" (binary long::xor)) + (/////bundle.install "shl" (binary long::shl)) + (/////bundle.install "shr" (binary long::shr)) + (/////bundle.install "ushr" (binary long::ushr)) + ))) + +(def: bundle::float + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.float)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary float::+)) + (/////bundle.install "-" (binary float::-)) + (/////bundle.install "*" (binary float::*)) + (/////bundle.install "/" (binary float::/)) + (/////bundle.install "%" (binary float::%)) + (/////bundle.install "=" (binary float::=)) + (/////bundle.install "<" (binary float::<)) + ))) + +(def: bundle::double + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.double)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "+" (binary double::+)) + (/////bundle.install "-" (binary double::-)) + (/////bundle.install "*" (binary double::*)) + (/////bundle.install "/" (binary double::/)) + (/////bundle.install "%" (binary double::%)) + (/////bundle.install "=" (binary double::=)) + (/////bundle.install "<" (binary double::<)) + ))) + +(def: bundle::char + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.char)) + (|> (: Bundle /////bundle.empty) + (/////bundle.install "=" (binary char::=)) + (/////bundle.install "<" (binary char::<)) + ))) + +(template [ ] + [(def: #export + (Parser (Type )) + (.embed .text))] + + [var Var parser.var] + [class category.Class parser.class] + [object Object parser.object] + [value Value parser.value] + [return Return parser.return] + ) + +(exception: #export (not-an-object-array {arrayJT (Type Array)}) + (exception.report + ["JVM Type" (|> arrayJT type.signature signature.signature)])) + +(def: #export object-array + (Parser (Type Object)) + (do <>.monad + [arrayJT (.embed parser.array .text)] + (case (parser.array? arrayJT) + (#.Some elementJT) + (case (parser.object? elementJT) + (#.Some elementJT) + (wrap elementJT) + + #.None + (<>.fail (exception.construct ..not-an-object-array arrayJT))) + + #.None + (undefined)))) + +(def: (primitive-array-length-handler jvm-primitive) + (-> (Type Primitive) Handler) + (..custom + [.any + (function (_ extension-name generate arrayS) + (do /////.monad + [arrayG (generate arrayS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array jvm-primitive)) + _.arraylength))))])) + +(def: array::length::object + Handler + (..custom + [($_ <>.and ..object-array .any) + (function (_ extension-name generate [elementJT arrayS]) + (do /////.monad + [arrayG (generate arrayS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array elementJT)) + _.arraylength))))])) + +(def: (new-primitive-array-handler jvm-primitive) + (-> Primitive-Array-Type Handler) + (..custom + [.any + (function (_ extension-name generate [lengthS]) + (do /////.monad + [lengthG (generate lengthS)] + (wrap ($_ _.compose + lengthG + (_.newarray jvm-primitive)))))])) + +(def: array::new::object + Handler + (..custom + [($_ <>.and ..object .any) + (function (_ extension-name generate [objectJT lengthS]) + (do /////.monad + [lengthG (generate lengthS)] + (wrap ($_ _.compose + lengthG + (_.anewarray objectJT)))))])) + +(def: (read-primitive-array-handler jvm-primitive loadG) + (-> (Type Primitive) (Bytecode Any) Handler) + (..custom + [($_ <>.and .any .any) + (function (_ extension-name generate [idxS arrayS]) + (do /////.monad + [arrayG (generate arrayS) + idxG (generate idxS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array jvm-primitive)) + idxG + loadG))))])) + +(def: array::read::object + Handler + (..custom + [($_ <>.and ..object-array .any .any) + (function (_ extension-name generate [elementJT idxS arrayS]) + (do /////.monad + [arrayG (generate arrayS) + idxG (generate idxS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array elementJT)) + idxG + _.aaload))))])) + +(def: (write-primitive-array-handler jvm-primitive storeG) + (-> (Type Primitive) (Bytecode Any) Handler) + (..custom + [($_ <>.and .any .any .any) + (function (_ extension-name generate [idxS valueS arrayS]) + (do /////.monad + [arrayG (generate arrayS) + idxG (generate idxS) + valueG (generate valueS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array jvm-primitive)) + _.dup + idxG + valueG + storeG))))])) + +(def: array::write::object + Handler + (..custom + [($_ <>.and ..object-array .any .any .any) + (function (_ extension-name generate [elementJT idxS valueS arrayS]) + (do /////.monad + [arrayG (generate arrayS) + idxG (generate idxS) + valueG (generate valueS)] + (wrap ($_ _.compose + arrayG + (_.checkcast (type.array elementJT)) + _.dup + idxG + valueG + _.aastore))))])) + +(def: bundle::array + Bundle + (<| (/////bundle.prefix "array") + (|> /////bundle.empty + (dictionary.merge (<| (/////bundle.prefix "length") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) + (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) + (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) + (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) + (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) + (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) + (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) + (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) + (/////bundle.install "object" array::length::object)))) + (dictionary.merge (<| (/////bundle.prefix "new") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean)) + (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte)) + (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short)) + (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int)) + (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long)) + (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float)) + (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double)) + (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char)) + (/////bundle.install "object" array::new::object)))) + (dictionary.merge (<| (/////bundle.prefix "read") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload)) + (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload)) + (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload)) + (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload)) + (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload)) + (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload)) + (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload)) + (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload)) + (/////bundle.install "object" array::read::object)))) + (dictionary.merge (<| (/////bundle.prefix "write") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore)) + (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore)) + (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore)) + (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore)) + (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore)) + (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore)) + (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore)) + (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore)) + (/////bundle.install "object" array::write::object)))) + ))) + +(def: (object::null _) + (Nullary (Bytecode Any)) + _.aconst-null) + +(def: (object::null? objectG) + (Unary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + objectG + (_.ifnull @then) + ..falseG + (_.goto @end) + (_.set-label @then) + ..trueG + (_.set-label @end)))) + +(def: (object::synchronized [monitorG exprG]) + (Binary (Bytecode Any)) + ($_ _.compose + monitorG + _.dup + _.monitorenter + exprG + _.swap + _.monitorexit)) + +(def: (object::throw exceptionG) + (Unary (Bytecode Any)) + ($_ _.compose + exceptionG + _.athrow)) + +(def: $Class (type.class "java.lang.Class" (list))) +(def: $String (type.class "java.lang.String" (list))) + +(def: object::class + Handler + (..custom + [.text + (function (_ extension-name generate [class]) + (do /////.monad + [] + (wrap ($_ _.compose + (_.string class) + (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))])) + +(def: object::instance? + Handler + (..custom + [($_ <>.and .text .any) + (function (_ extension-name generate [class objectS]) + (do /////.monad + [objectG (generate objectS)] + (wrap ($_ _.compose + objectG + (_.instanceof (type.class class (list))) + (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))])) + +(def: reflection + (All [category] + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def: object::cast + Handler + (..custom + [($_ <>.and .text .text .any) + (function (_ extension-name generate [from to valueS]) + (do /////.monad + [valueG (generate valueS)] + (wrap (`` (cond (~~ (template [ ] + [(and (text@= (..reflection ) + from) + (text@= + to)) + (let [$ (type.class (list))] + ($_ _.compose + valueG + (_.invokestatic $ "valueOf" (type.method [(list ) $ (list)])))) + + (and (text@= + from) + (text@= (..reflection ) + to)) + (let [$ (type.class (list))] + ($_ _.compose + valueG + (_.checkcast $) + (_.invokevirtual $ (type.method [(list) (list)]))))] + + [box.boolean type.boolean "booleanValue"] + [box.byte type.byte "byteValue"] + [box.short type.short "shortValue"] + [box.int type.int "intValue"] + [box.long type.long "longValue"] + [box.float type.float "floatValue"] + [box.double type.double "doubleValue"] + [box.char type.char "charValue"])) + ## else + valueG)))))])) + +(def: bundle::object + Bundle + (<| (/////bundle.prefix "object") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "null" (nullary object::null)) + (/////bundle.install "null?" (unary object::null?)) + (/////bundle.install "synchronized" (binary object::synchronized)) + (/////bundle.install "throw" (unary object::throw)) + (/////bundle.install "class" object::class) + (/////bundle.install "instance?" object::instance?) + (/////bundle.install "cast" object::cast) + ))) + +(def: primitives + (Dictionary Text (Type Primitive)) + (|> (list [(reflection.reflection reflection.boolean) type.boolean] + [(reflection.reflection reflection.byte) type.byte] + [(reflection.reflection reflection.short) type.short] + [(reflection.reflection reflection.int) type.int] + [(reflection.reflection reflection.long) type.long] + [(reflection.reflection reflection.float) type.float] + [(reflection.reflection reflection.double) type.double] + [(reflection.reflection reflection.char) type.char]) + (dictionary.from-list text.hash))) + +(def: get::static + Handler + (..custom + [($_ <>.and .text .text .text) + (function (_ extension-name generate [class field unboxed]) + (do /////.monad + [#let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap (_.getstatic $class field primitive)) + + #.None + (wrap (_.getstatic $class field (type.class unboxed (list)))))))])) + +(def: unitG (_.string //////synthesis.unit)) + +(def: put::static + Handler + (..custom + [($_ <>.and .text .text .text .any) + (function (_ extension-name generate [class field unboxed valueS]) + (do /////.monad + [valueG (generate valueS) + #let [$class (type.class class (list))]] + (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (wrap ($_ _.compose + valueG + (_.putstatic $class field primitive) + ..unitG)) + + #.None + (wrap ($_ _.compose + valueG + (_.checkcast $class) + (_.putstatic $class field $class) + ..unitG)))))])) + +(def: get::virtual + Handler + (..custom + [($_ <>.and .text .text .text .any) + (function (_ extension-name generate [class field unboxed objectS]) + (do /////.monad + [objectG (generate objectS) + #let [$class (type.class class (list)) + getG (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.getfield $class field primitive) + + #.None + (_.getfield $class field (type.class unboxed (list))))]] + (wrap ($_ _.compose + objectG + (_.checkcast $class) + getG))))])) + +(def: put::virtual + Handler + (..custom + [($_ <>.and .text .text .text .any .any) + (function (_ extension-name generate [class field unboxed valueS objectS]) + (do /////.monad + [valueG (generate valueS) + objectG (generate objectS) + #let [$class (type.class class (list)) + putG (case (dictionary.get unboxed ..primitives) + (#.Some primitive) + (_.putfield $class field primitive) + + #.None + (let [$unboxed (type.class unboxed (list))] + ($_ _.compose + (_.checkcast $unboxed) + (_.putfield $class field $unboxed))))]] + (wrap ($_ _.compose + objectG + (_.checkcast $class) + _.dup + valueG + putG))))])) + +(type: Input (Typed Synthesis)) + +(def: input + (Parser Input) + (.tuple (<>.and ..value .any))) + +(def: (generate-input generate [valueT valueS]) + (-> (-> Synthesis (Operation (Bytecode Any))) Input + (Operation (Typed (Bytecode Any)))) + (do /////.monad + [valueG (generate valueS)] + (case (type.primitive? valueT) + (#.Right valueT) + (wrap [valueT valueG]) + + (#.Left valueT) + (wrap [valueT ($_ _.compose + valueG + (_.checkcast valueT))])))) + +(def: (prepare-output outputT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? outputT) + (#.Right outputT) + ..unitG + + (#.Left outputT) + (:: _.monad wrap []))) + +(def: invoke::static + Handler + (..custom + [($_ <>.and ..class .text ..return (<>.some ..input)) + (function (_ extension-name generate [class method outputT inputsTS]) + (do /////.monad + [inputsTG (monad.map @ (generate-input generate) inputsTS)] + (wrap ($_ _.compose + (monad.map _.monad product.right inputsTG) + (_.invokestatic class method (type.method [(list@map product.left inputsTG) outputT (list)])) + (prepare-output outputT)))))])) + +(template [ ] + [(def: + Handler + (..custom + [($_ <>.and ..class .text ..return .any (<>.some ..input)) + (function (_ extension-name generate [class method outputT objectS inputsTS]) + (do /////.monad + [objectG (generate objectS) + inputsTG (monad.map @ (generate-input generate) inputsTS)] + (wrap ($_ _.compose + objectG + (_.checkcast class) + (monad.map _.monad product.right inputsTG) + ( class method (type.method [(list@map product.left inputsTG) outputT (list)])) + (prepare-output outputT)))))]))] + + [invoke::virtual _.invokevirtual] + [invoke::special _.invokespecial] + [invoke::interface _.invokeinterface] + ) + +(def: invoke::constructor + Handler + (..custom + [($_ <>.and ..class (<>.some ..input)) + (function (_ extension-name generate [class inputsTS]) + (do /////.monad + [inputsTG (monad.map @ (generate-input generate) inputsTS)] + (wrap ($_ _.compose + (_.new class) + _.dup + (monad.map _.monad product.right inputsTG) + (_.invokespecial class "" (type.method [(list@map product.left inputsTG) type.void (list)]))))))])) + +(def: bundle::member + Bundle + (<| (/////bundle.prefix "member") + (|> (: Bundle /////bundle.empty) + (dictionary.merge (<| (/////bundle.prefix "get") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "static" get::static) + (/////bundle.install "virtual" get::virtual)))) + (dictionary.merge (<| (/////bundle.prefix "put") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "static" put::static) + (/////bundle.install "virtual" put::virtual)))) + (dictionary.merge (<| (/////bundle.prefix "invoke") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "static" invoke::static) + (/////bundle.install "virtual" invoke::virtual) + (/////bundle.install "special" invoke::special) + (/////bundle.install "interface" invoke::interface) + (/////bundle.install "constructor" invoke::constructor)))) + ))) + +(def: annotation-parameter + (Parser (/.Annotation-Parameter Synthesis)) + (.tuple (<>.and .text .any))) + +(def: annotation + (Parser (/.Annotation Synthesis)) + (.tuple (<>.and .text (<>.some ..annotation-parameter)))) + +(def: argument + (Parser Argument) + (.tuple (<>.and .text ..value))) + +(def: overriden-method-definition + (Parser [Environment (/.Overriden-Method Synthesis)]) + (.tuple (do <>.monad + [_ (.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 + (.tuple .any))] + (wrap [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (//////synthesis.path/then bodyS)) + (//////synthesis.path/then (normalize bodyS)) + + (^template [] + (^ ( leftP rightP)) + ( (recur leftP) (recur rightP))) + ([#//////synthesis.Alt] + [#//////synthesis.Seq]) + + (^template [] + (^ ( value)) + path) + ([#//////synthesis.Pop] + [#//////synthesis.Test] + [#//////synthesis.Bind] + [#//////synthesis.Access])))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [] + (^ ( value)) + body) + ([#//////synthesis.Primitive] + [//////synthesis.constant]) + + (^ (//////synthesis.variant [lefts right? sub])) + (//////synthesis.variant [lefts right? (recur sub)]) + + (^ (//////synthesis.tuple members)) + (//////synthesis.tuple (list@map recur members)) + + (^ (//////synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + //////synthesis.variable) + + (^ (//////synthesis.branch/case [inputS pathS])) + (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (//////synthesis.branch/let [inputS register outputS])) + (//////synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (//////synthesis.branch/if [testS thenS elseS])) + (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) + (//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + + (^ (//////synthesis.loop/recur updatesS+)) + (//////synthesis.loop/recur (list@map recur updatesS+)) + + (^ (//////synthesis.function/abstraction [environment arity bodyS])) + (//////synthesis.function/abstraction [(|> environment (list@map (function (_ local) + (|> mapping + (dictionary.get local) + (maybe.default local))))) + arity + bodyS]) + + (^ (//////synthesis.function/apply [functionS inputsS+])) + (//////synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + + (#//////synthesis.Extension [name inputsS+]) + (#//////synthesis.Extension [name (list@map recur inputsS+)])))) + +(def: $Object (type.class "java.lang.Object" (list))) + +(def: (anonymous-init-method env) + (-> Environment (Type category.Method)) + (type.method [(list.repeat (list.size env) ..$Object) + type.void + (list)])) + +(def: (with-anonymous-init class env super-class inputsTG) + (-> (Type category.Class) Environment (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method)) + (let [store-capturedG (|> env + list.size + list.indices + (monad.map _.monad (.function (_ register) + ($_ _.compose + (_.aload 0) + (_.aload (inc register)) + (_.putfield class (///reference.foreign-name register) $Object)))))] + (method.method method.public "" (anonymous-init-method env) + (list) + (#.Some ($_ _.compose + (_.aload 0) + (monad.map _.monad product.right inputsTG) + (_.invokespecial super-class "" (type.method [(list@map product.left inputsTG) type.void (list)])) + store-capturedG + _.return))))) + +(def: (anonymous-instance class env) + (-> (Type category.Class) Environment (Operation (Bytecode Any))) + (do /////.monad + [captureG+ (monad.map @ ///reference.variable env)] + (wrap ($_ _.compose + (_.new class) + _.dup + (monad.seq _.monad captureG+) + (_.invokespecial class "" (anonymous-init-method env)))))) + +(def: (returnG returnT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? returnT) + (#.Right returnT) + _.return + + (#.Left returnT) + (case (type.primitive? returnT) + (#.Left returnT) + ($_ _.compose + (_.checkcast returnT) + _.areturn) + + (#.Right returnT) + (cond (or (:: type.equivalence = type.boolean returnT) + (:: type.equivalence = type.byte returnT) + (:: type.equivalence = type.short returnT) + (:: type.equivalence = type.int returnT) + (:: type.equivalence = type.char returnT)) + _.ireturn + + (:: type.equivalence = type.long returnT) + _.lreturn + + (:: type.equivalence = type.float returnT) + _.freturn + + ## (:: type.equivalence = type.double returnT) + _.dreturn)))) + +(def: class::anonymous + Handler + (..custom + [($_ <>.and + .text + ..class + (.tuple (<>.some ..class)) + (.tuple (<>.some ..input)) + (.tuple (<>.some ..overriden-method-definition))) + (function (_ extension-name generate [class-name + super-class super-interfaces + inputsTS + overriden-methods]) + (do /////.monad + [#let [class (type.class class-name (list)) + total-environment (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list //////reference.hash) + set.to-list) + global-mapping (|> total-environment + ## Give them names as "foreign" variables. + list.enumerate + (list@map (function (_ [id capture]) + [capture (#//////reference.Foreign id)])) + (dictionary.from-list //////reference.hash)) + normalized-methods (list@map (function (_ [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]]) + (let [local-mapping (|> environment + list.enumerate + (list@map (function (_ [foreign-id capture]) + [(#//////reference.Foreign foreign-id) + (|> global-mapping + (dictionary.get capture) + maybe.assume)])) + (dictionary.from-list //////reference.hash))] + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + (normalize-method-body local-mapping body)])) + overriden-methods)] + inputsTI (monad.map @ (generate-input generate) inputsTS) + method-definitions (monad.map @ (function (_ [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + bodyS]) + (do @ + [bodyG (//////generation.with-specific-context class-name + (generate bodyS))] + (wrap (method.method ($_ modifier@compose + method.public + method.final + (if strict-fp? + method.strict + modifier@identity)) + name + (type.method [(list@map product.right arguments) + returnT + exceptionsT]) + (list) + (#.Some ($_ _.compose + bodyG + (returnG returnT))))))) + normalized-methods) + bytecode (<| (:: @ map (format.run class.writer)) + /////.lift + (class.class version.v6_0 ($_ modifier@compose class.public class.final) + (name.internal class-name) + (name.internal (..reflection super-class)) + (list@map (|>> ..reflection name.internal) super-interfaces) + (foreign.variables total-environment) + (list& (..with-anonymous-init class total-environment super-class inputsTI) + method-definitions) + (row.row))) + _ (//////generation.save! true ["" class-name] [class-name bytecode])] + (anonymous-instance class total-environment)))])) + +(def: bundle::class + Bundle + (<| (/////bundle.prefix "class") + (|> (: Bundle /////bundle.empty) + (/////bundle.install "anonymous" class::anonymous) + ))) + +(def: #export bundle + Bundle + (<| (/////bundle.prefix "jvm") + (|> ..bundle::conversion + (dictionary.merge ..bundle::int) + (dictionary.merge ..bundle::long) + (dictionary.merge ..bundle::float) + (dictionary.merge ..bundle::double) + (dictionary.merge ..bundle::char) + (dictionary.merge ..bundle::array) + (dictionary.merge ..bundle::object) + (dictionary.merge ..bundle::member) + (dictionary.merge ..bundle::class) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux deleted file mode 100644 index d436d1974..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [// - [runtime (#+ Bundle)]]]) - -(def: #export bundle - Bundle - ($_ dictionary.merge - /common.bundle - /host.bundle - )) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux deleted file mode 100644 index d57dd6b50..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/common.lux +++ /dev/null @@ -1,448 +0,0 @@ -(.module: - [lux (#- Type) - [host (#+ import:)] - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["" synthesis (#+ Parser)]]] - [data - ["." product] - [number - ["." i32] - ["f" frac]] - [collection - ["." list ("#@." monad)] - ["." dictionary]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#@." monad)] - [encoding - ["." signed (#+ S4)]] - ["." type (#+ Type) - [category (#+ Primitive Class)]]]]] - ["." /// - ["#." value] - ["#." runtime (#+ Operation Phase Bundle Handler)] - ["#." function #_ - ["#" abstract]] - ["//#" /// - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)]] - [extension - ["#extension" /] - ["#." bundle]] - ["/#" // - ["#." synthesis (#+ Synthesis %synthesis)]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase s (Operation (Bytecode Any)))] - Handler)) - (function (_ extension-name phase input) - (case (.run parser input) - (#try.Success input') - (handler extension-name phase input') - - (#try.Failure error) - (/////.throw /////extension.invalid-syntax [extension-name //////synthesis.%synthesis input])))) - -(def: $Boolean (type.class "java.lang.Boolean" (list))) -(def: $Double (type.class "java.lang.Double" (list))) -(def: $Character (type.class "java.lang.Character" (list))) -(def: $String (type.class "java.lang.String" (list))) -(def: $CharSequence (type.class "java.lang.CharSequence" (list))) -(def: $Object (type.class "java.lang.Object" (list))) -(def: $PrintStream (type.class "java.io.PrintStream" (list))) -(def: $System (type.class "java.lang.System" (list))) -(def: $Error (type.class "java.lang.Error" (list))) - -(def: lux-int - (Bytecode Any) - ($_ _.compose - _.i2l - (///value.wrap type.long))) - -(def: jvm-int - (Bytecode Any) - ($_ _.compose - (///value.unwrap type.long) - _.l2i)) - -(def: ensure-string - (Bytecode Any) - (_.checkcast $String)) - -(def: (predicate bytecode) - (-> (-> Label (Bytecode Any)) - (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - (bytecode @then) - (_.getstatic $Boolean "FALSE" $Boolean) - (_.goto @end) - (_.set-label @then) - (_.getstatic $Boolean "TRUE" $Boolean) - (_.set-label @end) - ))) - -## 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 [inputS elseS conditionalsS]) - (do /////.monad - [@end ///runtime.forge-label - inputG (phase inputS) - elseG (phase elseS) - conditionalsG+ (: (Operation (List [(List [S4 Label]) - (Bytecode Any)])) - (monad.map @ (function (_ [chars branch]) - (do @ - [branchG (phase branch) - @branch ///runtime.forge-label] - (wrap [(list@map (function (_ char) - [(try.assume (signed.s4 (.int char))) @branch]) - chars) - ($_ _.compose - (_.set-label @branch) - branchG - (_.goto @end))]))) - conditionalsS)) - #let [table (|> conditionalsG+ - (list@map product.left) - list@join) - conditionalsG (|> conditionalsG+ - (list@map product.right) - (monad.seq _.monad))]] - (wrap (do _.monad - [@else _.new-label] - ($_ _.compose - inputG (///value.unwrap type.long) _.l2i - (_.lookupswitch @else table) - conditionalsG - (_.set-label @else) - elseG - (_.set-label @end) - )))))])) - -(def: (lux::is [referenceG sampleG]) - (Binary (Bytecode Any)) - ($_ _.compose - referenceG - sampleG - (..predicate _.if-acmpeq))) - -(def: (lux::try riskyG) - (Unary (Bytecode Any)) - ($_ _.compose - riskyG - (_.checkcast ///function.class) - ///runtime.try)) - -(def: bundle::lux - Bundle - (|> (: Bundle /////bundle.empty) - (/////bundle.install "syntax char case!" ..lux::syntax-char-case!) - (/////bundle.install "is" (binary ..lux::is)) - (/////bundle.install "try" (unary ..lux::try)))) - -(template [ ] - [(def: ( [maskG inputG]) - (Binary (Bytecode Any)) - ($_ _.compose - inputG (///value.unwrap type.long) - maskG (///value.unwrap type.long) - (///value.wrap type.long)))] - - [i64::and _.land] - [i64::or _.lor] - [i64::xor _.lxor] - ) - -(template [ ] - [(def: ( [shiftG inputG]) - (Binary (Bytecode Any)) - ($_ _.compose - inputG (///value.unwrap type.long) - shiftG ..jvm-int - (///value.wrap type.long)))] - - [i64::left-shift _.lshl] - [i64::arithmetic-right-shift _.lshr] - [i64::logical-right-shift _.lushr] - ) - -(import: #long java/lang/Double - (#static MIN_VALUE double) - (#static MAX_VALUE double)) - -(template [ ] - [(def: ( _) - (Nullary (Bytecode Any)) - ($_ _.compose - (_.double ) - (///value.wrap type.double)))] - - [f64::smallest (java/lang/Double::MIN_VALUE)] - [f64::min (f.* -1.0 (java/lang/Double::MAX_VALUE))] - [f64::max (java/lang/Double::MAX_VALUE)] - ) - -(template [ ] - [(def: ( [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG (///value.unwrap ) - paramG (///value.unwrap ) - (///value.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: ( [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG (///value.unwrap ) - paramG (///value.unwrap ) - - - (..predicate _.if-icmpeq)))] - - [ _.iconst-0] - [ _.iconst-m1])] - - [i64::= i64::< type.long _.lcmp] - [f64::= f64::< type.double _.dcmpg] - ) - -(def: (to-string class from) - (-> (Type Class) (Type Primitive) (Bytecode Any)) - (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) - -(template [ ] - [(def: ( inputG) - (Unary (Bytecode Any)) - ($_ _.compose - inputG - - ))] - - [i64::f64 - (///value.unwrap type.long) - ($_ _.compose - _.l2d - (///value.wrap type.double))] - - [i64::char - (///value.unwrap type.long) - ($_ _.compose - _.l2i - _.i2c - (..to-string ..$Character type.char))] - - [f64::i64 - (///value.unwrap type.double) - ($_ _.compose - _.d2l - (///value.wrap type.long))] - - [f64::encode - (///value.unwrap type.double) - (..to-string ..$Double type.double)] - - [f64::decode - ..ensure-string - ///runtime.decode-frac] - ) - -(def: bundle::i64 - Bundle - (<| (/////bundle.prefix "i64") - (|> (: 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 "logical-right-shift" (binary ..i64::logical-right-shift)) - (/////bundle.install "arithmetic-right-shift" (binary ..i64::arithmetic-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") - (|> (: 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 "smallest" (nullary ..f64::smallest)) - (/////bundle.install "min" (nullary ..f64::min)) - (/////bundle.install "max" (nullary ..f64::max)) - (/////bundle.install "i64" (unary ..f64::i64)) - (/////bundle.install "encode" (unary ..f64::encode)) - (/////bundle.install "decode" (unary ..f64::decode))))) - -(def: (text::size inputG) - (Unary (Bytecode Any)) - ($_ _.compose - inputG - ..ensure-string - (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) - ..lux-int)) - -(def: no-op (Bytecode Any) (_@wrap [])) - -(template [ ] - [(def: ( [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG - paramG - ))] - - [text::= ..no-op ..no-op - (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) - (///value.wrap type.boolean)] - [text::< ..ensure-string ..ensure-string - (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) - (..predicate _.iflt)] - [text::char ..ensure-string ..jvm-int - (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) - ..lux-int] - ) - -(def: (text::concat [leftG rightG]) - (Binary (Bytecode Any)) - ($_ _.compose - leftG ..ensure-string - rightG ..ensure-string - (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) - -(def: (text::clip [startG endG subjectG]) - (Trinary (Bytecode Any)) - ($_ _.compose - subjectG ..ensure-string - startG ..jvm-int - endG ..jvm-int - (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)])))) - -(def: index-method (type.method [(list ..$String type.int) type.int (list)])) -(def: (text::index [startG partG textG]) - (Trinary (Bytecode Any)) - (do _.monad - [@not-found _.new-label - @end _.new-label] - ($_ _.compose - textG ..ensure-string - partG ..ensure-string - startG ..jvm-int - (_.invokevirtual ..$String "indexOf" index-method) - _.dup - _.iconst-m1 - (_.if-icmpeq @not-found) - ..lux-int - ///runtime.some-injection - (_.goto @end) - (_.set-label @not-found) - _.pop - ///runtime.none-injection - (_.set-label @end)))) - -(def: bundle::text - Bundle - (<| (/////bundle.prefix "text") - (|> (: 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: string-method (type.method [(list ..$String) type.void (list)])) -(def: (io::log messageG) - (Unary (Bytecode Any)) - ($_ _.compose - (_.getstatic ..$System "out" ..$PrintStream) - messageG - ..ensure-string - (_.invokevirtual ..$PrintStream "println" ..string-method) - ///runtime.unit)) - -(def: (io::error messageG) - (Unary (Bytecode Any)) - ($_ _.compose - (_.new ..$Error) - _.dup - messageG - ..ensure-string - (_.invokespecial ..$Error "" ..string-method) - _.athrow)) - -(def: exit-method (type.method [(list type.int) type.void (list)])) -(def: (io::exit codeG) - (Unary (Bytecode Any)) - ($_ _.compose - codeG ..jvm-int - (_.invokestatic ..$System "exit" ..exit-method) - _.aconst-null)) - -(def: time-method (type.method [(list) type.long (list)])) -(def: (io::current-time _) - (Nullary (Bytecode Any)) - ($_ _.compose - (_.invokestatic ..$System "currentTimeMillis" ..time-method) - (///value.wrap type.long))) - -(def: bundle::io - Bundle - (<| (/////bundle.prefix "io") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "log" (unary ..io::log)) - (/////bundle.install "error" (unary ..io::error)) - (/////bundle.install "exit" (unary ..io::exit)) - (/////bundle.install "current-time" (nullary ..io::current-time))))) - -(def: #export bundle - Bundle - (<| (/////bundle.prefix "lux") - (|> bundle::lux - (dictionary.merge ..bundle::i64) - (dictionary.merge ..bundle::f64) - (dictionary.merge ..bundle::text) - (dictionary.merge ..bundle::io)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux deleted file mode 100644 index 84af963d2..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux +++ /dev/null @@ -1,1086 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["" text] - ["" synthesis (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#@." equivalence)] - [number - ["." i32]] - [collection - ["." list ("#@." monad)] - ["." dictionary (#+ Dictionary)] - ["." set] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." version] - ["." modifier ("#@." monoid)] - ["." method (#+ Method)] - ["." class (#+ Class)] - [constant - [pool (#+ Resource)]] - [encoding - ["." name]] - ["_" bytecode (#+ Label Bytecode) ("#@." monad) - ["__" instruction (#+ Primitive-Array-Type)]] - ["." type (#+ Type Typed Argument) - ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)] - ["." box] - ["." reflection] - ["." signature] - ["." parser]]]]] - ["." // #_ - [common (#+ custom)] - ["/#" // - [runtime (#+ Operation Bundle Handler)] - ["#." reference] - [function - [field - [variable - ["." foreign]]]] - ["//#" /// - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)]] - [extension - ["#." bundle] - [analysis - ["/" jvm]]] - ["/#" // - ["#." reference (#+ Variable)] - [analysis (#+ Environment)] - ["#." synthesis (#+ Synthesis Path %synthesis)] - ["#." generation]]]]]) - -(template [ <0> <1>] - [(def: - (Bytecode Any) - ($_ _.compose - <0> - <1>))] - - [l2s _.l2i _.i2s] - [l2b _.l2i _.i2b] - [l2c _.l2i _.i2c] - ) - -(template [ ] - [(def: ( inputG) - (Unary (Bytecode Any)) - (if (is? _.nop ) - inputG - ($_ _.compose - inputG - )))] - - [_.d2f conversion::double-to-float] - [_.d2i conversion::double-to-int] - [_.d2l conversion::double-to-long] - [_.f2d conversion::float-to-double] - [_.f2i conversion::float-to-int] - [_.f2l conversion::float-to-long] - [_.i2b conversion::int-to-byte] - [_.i2c conversion::int-to-char] - [_.i2d conversion::int-to-double] - [_.i2f conversion::int-to-float] - [_.i2l conversion::int-to-long] - [_.i2s conversion::int-to-short] - [_.l2d conversion::long-to-double] - [_.l2f conversion::long-to-float] - [_.l2i conversion::long-to-int] - [..l2s conversion::long-to-short] - [..l2b conversion::long-to-byte] - [..l2c conversion::long-to-char] - [_.i2b conversion::char-to-byte] - [_.i2s conversion::char-to-short] - [_.nop conversion::char-to-int] - [_.i2l conversion::char-to-long] - [_.i2l conversion::byte-to-long] - [_.i2l conversion::short-to-long] - ) - -(def: bundle::conversion - Bundle - (<| (/////bundle.prefix "conversion") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "double-to-float" (unary conversion::double-to-float)) - (/////bundle.install "double-to-int" (unary conversion::double-to-int)) - (/////bundle.install "double-to-long" (unary conversion::double-to-long)) - (/////bundle.install "float-to-double" (unary conversion::float-to-double)) - (/////bundle.install "float-to-int" (unary conversion::float-to-int)) - (/////bundle.install "float-to-long" (unary conversion::float-to-long)) - (/////bundle.install "int-to-byte" (unary conversion::int-to-byte)) - (/////bundle.install "int-to-char" (unary conversion::int-to-char)) - (/////bundle.install "int-to-double" (unary conversion::int-to-double)) - (/////bundle.install "int-to-float" (unary conversion::int-to-float)) - (/////bundle.install "int-to-long" (unary conversion::int-to-long)) - (/////bundle.install "int-to-short" (unary conversion::int-to-short)) - (/////bundle.install "long-to-double" (unary conversion::long-to-double)) - (/////bundle.install "long-to-float" (unary conversion::long-to-float)) - (/////bundle.install "long-to-int" (unary conversion::long-to-int)) - (/////bundle.install "long-to-short" (unary conversion::long-to-short)) - (/////bundle.install "long-to-byte" (unary conversion::long-to-byte)) - (/////bundle.install "long-to-char" (unary conversion::long-to-char)) - (/////bundle.install "char-to-byte" (unary conversion::char-to-byte)) - (/////bundle.install "char-to-short" (unary conversion::char-to-short)) - (/////bundle.install "char-to-int" (unary conversion::char-to-int)) - (/////bundle.install "char-to-long" (unary conversion::char-to-long)) - (/////bundle.install "byte-to-long" (unary conversion::byte-to-long)) - (/////bundle.install "short-to-long" (unary conversion::short-to-long)) - ))) - -(template [ ] - [(def: ( [xG yG]) - (Binary (Bytecode Any)) - ($_ _.compose - xG - yG - ))] - - [int::+ _.iadd] - [int::- _.isub] - [int::* _.imul] - [int::/ _.idiv] - [int::% _.irem] - [int::and _.iand] - [int::or _.ior] - [int::xor _.ixor] - [int::shl _.ishl] - [int::shr _.ishr] - [int::ushr _.iushr] - - [long::+ _.ladd] - [long::- _.lsub] - [long::* _.lmul] - [long::/ _.ldiv] - [long::% _.lrem] - [long::and _.land] - [long::or _.lor] - [long::xor _.lxor] - [long::shl _.lshl] - [long::shr _.lshr] - [long::ushr _.lushr] - - [float::+ _.fadd] - [float::- _.fsub] - [float::* _.fmul] - [float::/ _.fdiv] - [float::% _.frem] - - [double::+ _.dadd] - [double::- _.dsub] - [double::* _.dmul] - [double::/ _.ddiv] - [double::% _.drem] - ) - -(def: $Boolean (type.class box.boolean (list))) -(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean)) -(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean)) - -(template [ ] - [(def: ( [xG yG]) - (Binary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - xG - yG - ( @then) - falseG - (_.goto @end) - (_.set-label @then) - trueG - (_.set-label @end))))] - - [int::= _.if-icmpeq] - [int::< _.if-icmplt] - - [char::= _.if-icmpeq] - [char::< _.if-icmplt] - ) - -(template [ ] - [(def: ( [xG yG]) - (Binary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - xG - yG - - (_.int (i32.i32 (.i64 ))) - (_.if-icmpeq @then) - falseG - (_.goto @end) - (_.set-label @then) - trueG - (_.set-label @end))))] - - [long::= _.lcmp +0] - [long::< _.lcmp -1] - - [float::= _.fcmpg +0] - [float::< _.fcmpg -1] - - [double::= _.dcmpg +0] - [double::< _.dcmpg -1] - ) - -(def: bundle::int - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.int)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary int::+)) - (/////bundle.install "-" (binary int::-)) - (/////bundle.install "*" (binary int::*)) - (/////bundle.install "/" (binary int::/)) - (/////bundle.install "%" (binary int::%)) - (/////bundle.install "=" (binary int::=)) - (/////bundle.install "<" (binary int::<)) - (/////bundle.install "and" (binary int::and)) - (/////bundle.install "or" (binary int::or)) - (/////bundle.install "xor" (binary int::xor)) - (/////bundle.install "shl" (binary int::shl)) - (/////bundle.install "shr" (binary int::shr)) - (/////bundle.install "ushr" (binary int::ushr)) - ))) - -(def: bundle::long - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.long)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary long::+)) - (/////bundle.install "-" (binary long::-)) - (/////bundle.install "*" (binary long::*)) - (/////bundle.install "/" (binary long::/)) - (/////bundle.install "%" (binary long::%)) - (/////bundle.install "=" (binary long::=)) - (/////bundle.install "<" (binary long::<)) - (/////bundle.install "and" (binary long::and)) - (/////bundle.install "or" (binary long::or)) - (/////bundle.install "xor" (binary long::xor)) - (/////bundle.install "shl" (binary long::shl)) - (/////bundle.install "shr" (binary long::shr)) - (/////bundle.install "ushr" (binary long::ushr)) - ))) - -(def: bundle::float - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.float)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary float::+)) - (/////bundle.install "-" (binary float::-)) - (/////bundle.install "*" (binary float::*)) - (/////bundle.install "/" (binary float::/)) - (/////bundle.install "%" (binary float::%)) - (/////bundle.install "=" (binary float::=)) - (/////bundle.install "<" (binary float::<)) - ))) - -(def: bundle::double - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.double)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "+" (binary double::+)) - (/////bundle.install "-" (binary double::-)) - (/////bundle.install "*" (binary double::*)) - (/////bundle.install "/" (binary double::/)) - (/////bundle.install "%" (binary double::%)) - (/////bundle.install "=" (binary double::=)) - (/////bundle.install "<" (binary double::<)) - ))) - -(def: bundle::char - Bundle - (<| (/////bundle.prefix (reflection.reflection reflection.char)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "=" (binary char::=)) - (/////bundle.install "<" (binary char::<)) - ))) - -(template [ ] - [(def: #export - (Parser (Type )) - (.embed .text))] - - [var Var parser.var] - [class category.Class parser.class] - [object Object parser.object] - [value Value parser.value] - [return Return parser.return] - ) - -(exception: #export (not-an-object-array {arrayJT (Type Array)}) - (exception.report - ["JVM Type" (|> arrayJT type.signature signature.signature)])) - -(def: #export object-array - (Parser (Type Object)) - (do <>.monad - [arrayJT (.embed parser.array .text)] - (case (parser.array? arrayJT) - (#.Some elementJT) - (case (parser.object? elementJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (<>.fail (exception.construct ..not-an-object-array arrayJT))) - - #.None - (undefined)))) - -(def: (primitive-array-length-handler jvm-primitive) - (-> (Type Primitive) Handler) - (..custom - [.any - (function (_ extension-name generate arrayS) - (do /////.monad - [arrayG (generate arrayS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - _.arraylength))))])) - -(def: array::length::object - Handler - (..custom - [($_ <>.and ..object-array .any) - (function (_ extension-name generate [elementJT arrayS]) - (do /////.monad - [arrayG (generate arrayS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - _.arraylength))))])) - -(def: (new-primitive-array-handler jvm-primitive) - (-> Primitive-Array-Type Handler) - (..custom - [.any - (function (_ extension-name generate [lengthS]) - (do /////.monad - [lengthG (generate lengthS)] - (wrap ($_ _.compose - lengthG - (_.newarray jvm-primitive)))))])) - -(def: array::new::object - Handler - (..custom - [($_ <>.and ..object .any) - (function (_ extension-name generate [objectJT lengthS]) - (do /////.monad - [lengthG (generate lengthS)] - (wrap ($_ _.compose - lengthG - (_.anewarray objectJT)))))])) - -(def: (read-primitive-array-handler jvm-primitive loadG) - (-> (Type Primitive) (Bytecode Any) Handler) - (..custom - [($_ <>.and .any .any) - (function (_ extension-name generate [idxS arrayS]) - (do /////.monad - [arrayG (generate arrayS) - idxG (generate idxS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - idxG - loadG))))])) - -(def: array::read::object - Handler - (..custom - [($_ <>.and ..object-array .any .any) - (function (_ extension-name generate [elementJT idxS arrayS]) - (do /////.monad - [arrayG (generate arrayS) - idxG (generate idxS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - idxG - _.aaload))))])) - -(def: (write-primitive-array-handler jvm-primitive storeG) - (-> (Type Primitive) (Bytecode Any) Handler) - (..custom - [($_ <>.and .any .any .any) - (function (_ extension-name generate [idxS valueS arrayS]) - (do /////.monad - [arrayG (generate arrayS) - idxG (generate idxS) - valueG (generate valueS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - _.dup - idxG - valueG - storeG))))])) - -(def: array::write::object - Handler - (..custom - [($_ <>.and ..object-array .any .any .any) - (function (_ extension-name generate [elementJT idxS valueS arrayS]) - (do /////.monad - [arrayG (generate arrayS) - idxG (generate idxS) - valueG (generate valueS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - _.dup - idxG - valueG - _.aastore))))])) - -(def: bundle::array - Bundle - (<| (/////bundle.prefix "array") - (|> /////bundle.empty - (dictionary.merge (<| (/////bundle.prefix "length") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean)) - (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte)) - (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short)) - (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int)) - (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long)) - (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float)) - (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double)) - (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char)) - (/////bundle.install "object" array::length::object)))) - (dictionary.merge (<| (/////bundle.prefix "new") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean)) - (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte)) - (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short)) - (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int)) - (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long)) - (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float)) - (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double)) - (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char)) - (/////bundle.install "object" array::new::object)))) - (dictionary.merge (<| (/////bundle.prefix "read") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload)) - (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload)) - (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload)) - (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload)) - (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload)) - (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload)) - (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload)) - (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload)) - (/////bundle.install "object" array::read::object)))) - (dictionary.merge (<| (/////bundle.prefix "write") - (|> /////bundle.empty - (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore)) - (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore)) - (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore)) - (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore)) - (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore)) - (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore)) - (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore)) - (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore)) - (/////bundle.install "object" array::write::object)))) - ))) - -(def: (object::null _) - (Nullary (Bytecode Any)) - _.aconst-null) - -(def: (object::null? objectG) - (Unary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - objectG - (_.ifnull @then) - ..falseG - (_.goto @end) - (_.set-label @then) - ..trueG - (_.set-label @end)))) - -(def: (object::synchronized [monitorG exprG]) - (Binary (Bytecode Any)) - ($_ _.compose - monitorG - _.dup - _.monitorenter - exprG - _.swap - _.monitorexit)) - -(def: (object::throw exceptionG) - (Unary (Bytecode Any)) - ($_ _.compose - exceptionG - _.athrow)) - -(def: $Class (type.class "java.lang.Class" (list))) -(def: $String (type.class "java.lang.String" (list))) - -(def: object::class - Handler - (..custom - [.text - (function (_ extension-name generate [class]) - (do /////.monad - [] - (wrap ($_ _.compose - (_.string class) - (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))])) - -(def: object::instance? - Handler - (..custom - [($_ <>.and .text .any) - (function (_ extension-name generate [class objectS]) - (do /////.monad - [objectG (generate objectS)] - (wrap ($_ _.compose - objectG - (_.instanceof (type.class class (list))) - (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))])) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(def: object::cast - Handler - (..custom - [($_ <>.and .text .text .any) - (function (_ extension-name generate [from to valueS]) - (do /////.monad - [valueG (generate valueS)] - (wrap (`` (cond (~~ (template [ ] - [(and (text@= (..reflection ) - from) - (text@= - to)) - (let [$ (type.class (list))] - ($_ _.compose - valueG - (_.invokestatic $ "valueOf" (type.method [(list ) $ (list)])))) - - (and (text@= - from) - (text@= (..reflection ) - to)) - (let [$ (type.class (list))] - ($_ _.compose - valueG - (_.checkcast $) - (_.invokevirtual $ (type.method [(list) (list)]))))] - - [box.boolean type.boolean "booleanValue"] - [box.byte type.byte "byteValue"] - [box.short type.short "shortValue"] - [box.int type.int "intValue"] - [box.long type.long "longValue"] - [box.float type.float "floatValue"] - [box.double type.double "doubleValue"] - [box.char type.char "charValue"])) - ## else - valueG)))))])) - -(def: bundle::object - Bundle - (<| (/////bundle.prefix "object") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "null" (nullary object::null)) - (/////bundle.install "null?" (unary object::null?)) - (/////bundle.install "synchronized" (binary object::synchronized)) - (/////bundle.install "throw" (unary object::throw)) - (/////bundle.install "class" object::class) - (/////bundle.install "instance?" object::instance?) - (/////bundle.install "cast" object::cast) - ))) - -(def: primitives - (Dictionary Text (Type Primitive)) - (|> (list [(reflection.reflection reflection.boolean) type.boolean] - [(reflection.reflection reflection.byte) type.byte] - [(reflection.reflection reflection.short) type.short] - [(reflection.reflection reflection.int) type.int] - [(reflection.reflection reflection.long) type.long] - [(reflection.reflection reflection.float) type.float] - [(reflection.reflection reflection.double) type.double] - [(reflection.reflection reflection.char) type.char]) - (dictionary.from-list text.hash))) - -(def: get::static - Handler - (..custom - [($_ <>.and .text .text .text) - (function (_ extension-name generate [class field unboxed]) - (do /////.monad - [#let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.getstatic $class field primitive)) - - #.None - (wrap (_.getstatic $class field (type.class unboxed (list)))))))])) - -(def: unitG (_.string //////synthesis.unit)) - -(def: put::static - Handler - (..custom - [($_ <>.and .text .text .text .any) - (function (_ extension-name generate [class field unboxed valueS]) - (do /////.monad - [valueG (generate valueS) - #let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap ($_ _.compose - valueG - (_.putstatic $class field primitive) - ..unitG)) - - #.None - (wrap ($_ _.compose - valueG - (_.checkcast $class) - (_.putstatic $class field $class) - ..unitG)))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and .text .text .text .any) - (function (_ extension-name generate [class field unboxed objectS]) - (do /////.monad - [objectG (generate objectS) - #let [$class (type.class class (list)) - getG (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.getfield $class field primitive) - - #.None - (_.getfield $class field (type.class unboxed (list))))]] - (wrap ($_ _.compose - objectG - (_.checkcast $class) - getG))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and .text .text .text .any .any) - (function (_ extension-name generate [class field unboxed valueS objectS]) - (do /////.monad - [valueG (generate valueS) - objectG (generate objectS) - #let [$class (type.class class (list)) - putG (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.putfield $class field primitive) - - #.None - (let [$unboxed (type.class unboxed (list))] - ($_ _.compose - (_.checkcast $unboxed) - (_.putfield $class field $unboxed))))]] - (wrap ($_ _.compose - objectG - (_.checkcast $class) - _.dup - valueG - putG))))])) - -(type: Input (Typed Synthesis)) - -(def: input - (Parser Input) - (.tuple (<>.and ..value .any))) - -(def: (generate-input generate [valueT valueS]) - (-> (-> Synthesis (Operation (Bytecode Any))) Input - (Operation (Typed (Bytecode Any)))) - (do /////.monad - [valueG (generate valueS)] - (case (type.primitive? valueT) - (#.Right valueT) - (wrap [valueT valueG]) - - (#.Left valueT) - (wrap [valueT ($_ _.compose - valueG - (_.checkcast valueT))])))) - -(def: (prepare-output outputT) - (-> (Type Return) (Bytecode Any)) - (case (type.void? outputT) - (#.Right outputT) - ..unitG - - (#.Left outputT) - (:: _.monad wrap []))) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..class .text ..return (<>.some ..input)) - (function (_ extension-name generate [class method outputT inputsTS]) - (do /////.monad - [inputsTG (monad.map @ (generate-input generate) inputsTS)] - (wrap ($_ _.compose - (monad.map _.monad product.right inputsTG) - (_.invokestatic class method (type.method [(list@map product.left inputsTG) outputT (list)])) - (prepare-output outputT)))))])) - -(template [ ] - [(def: - Handler - (..custom - [($_ <>.and ..class .text ..return .any (<>.some ..input)) - (function (_ extension-name generate [class method outputT objectS inputsTS]) - (do /////.monad - [objectG (generate objectS) - inputsTG (monad.map @ (generate-input generate) inputsTS)] - (wrap ($_ _.compose - objectG - (_.checkcast class) - (monad.map _.monad product.right inputsTG) - ( class method (type.method [(list@map product.left inputsTG) outputT (list)])) - (prepare-output outputT)))))]))] - - [invoke::virtual _.invokevirtual] - [invoke::special _.invokespecial] - [invoke::interface _.invokeinterface] - ) - -(def: invoke::constructor - Handler - (..custom - [($_ <>.and ..class (<>.some ..input)) - (function (_ extension-name generate [class inputsTS]) - (do /////.monad - [inputsTG (monad.map @ (generate-input generate) inputsTS)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.map _.monad product.right inputsTG) - (_.invokespecial class "" (type.method [(list@map product.left inputsTG) type.void (list)]))))))])) - -(def: bundle::member - Bundle - (<| (/////bundle.prefix "member") - (|> (: Bundle /////bundle.empty) - (dictionary.merge (<| (/////bundle.prefix "get") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" get::static) - (/////bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (/////bundle.prefix "put") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" put::static) - (/////bundle.install "virtual" put::virtual)))) - (dictionary.merge (<| (/////bundle.prefix "invoke") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" invoke::static) - (/////bundle.install "virtual" invoke::virtual) - (/////bundle.install "special" invoke::special) - (/////bundle.install "interface" invoke::interface) - (/////bundle.install "constructor" invoke::constructor)))) - ))) - -(def: annotation-parameter - (Parser (/.Annotation-Parameter Synthesis)) - (.tuple (<>.and .text .any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (.tuple (<>.and .text (<>.some ..annotation-parameter)))) - -(def: argument - (Parser Argument) - (.tuple (<>.and .text ..value))) - -(def: overriden-method-definition - (Parser [Environment (/.Overriden-Method Synthesis)]) - (.tuple (do <>.monad - [_ (.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 - (.tuple .any))] - (wrap [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]])))) - -(def: (normalize-path normalize) - (-> (-> Synthesis Synthesis) - (-> Path Path)) - (function (recur path) - (case path - (^ (//////synthesis.path/then bodyS)) - (//////synthesis.path/then (normalize bodyS)) - - (^template [] - (^ ( leftP rightP)) - ( (recur leftP) (recur rightP))) - ([#//////synthesis.Alt] - [#//////synthesis.Seq]) - - (^template [] - (^ ( value)) - path) - ([#//////synthesis.Pop] - [#//////synthesis.Test] - [#//////synthesis.Bind] - [#//////synthesis.Access])))) - -(def: (normalize-method-body mapping) - (-> (Dictionary Variable Variable) Synthesis Synthesis) - (function (recur body) - (case body - (^template [] - (^ ( value)) - body) - ([#//////synthesis.Primitive] - [//////synthesis.constant]) - - (^ (//////synthesis.variant [lefts right? sub])) - (//////synthesis.variant [lefts right? (recur sub)]) - - (^ (//////synthesis.tuple members)) - (//////synthesis.tuple (list@map recur members)) - - (^ (//////synthesis.variable var)) - (|> mapping - (dictionary.get var) - (maybe.default var) - //////synthesis.variable) - - (^ (//////synthesis.branch/case [inputS pathS])) - (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) - - (^ (//////synthesis.branch/let [inputS register outputS])) - (//////synthesis.branch/let [(recur inputS) register (recur outputS)]) - - (^ (//////synthesis.branch/if [testS thenS elseS])) - (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) - - (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) - (//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) - - (^ (//////synthesis.loop/recur updatesS+)) - (//////synthesis.loop/recur (list@map recur updatesS+)) - - (^ (//////synthesis.function/abstraction [environment arity bodyS])) - (//////synthesis.function/abstraction [(|> environment (list@map (function (_ local) - (|> mapping - (dictionary.get local) - (maybe.default local))))) - arity - bodyS]) - - (^ (//////synthesis.function/apply [functionS inputsS+])) - (//////synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) - - (#//////synthesis.Extension [name inputsS+]) - (#//////synthesis.Extension [name (list@map recur inputsS+)])))) - -(def: $Object (type.class "java.lang.Object" (list))) - -(def: (anonymous-init-method env) - (-> Environment (Type category.Method)) - (type.method [(list.repeat (list.size env) ..$Object) - type.void - (list)])) - -(def: (with-anonymous-init class env super-class inputsTG) - (-> (Type category.Class) Environment (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method)) - (let [store-capturedG (|> env - list.size - list.indices - (monad.map _.monad (.function (_ register) - ($_ _.compose - (_.aload 0) - (_.aload (inc register)) - (_.putfield class (///reference.foreign-name register) $Object)))))] - (method.method method.public "" (anonymous-init-method env) - (list) - (#.Some ($_ _.compose - (_.aload 0) - (monad.map _.monad product.right inputsTG) - (_.invokespecial super-class "" (type.method [(list@map product.left inputsTG) type.void (list)])) - store-capturedG - _.return))))) - -(def: (anonymous-instance class env) - (-> (Type category.Class) Environment (Operation (Bytecode Any))) - (do /////.monad - [captureG+ (monad.map @ ///reference.variable env)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.seq _.monad captureG+) - (_.invokespecial class "" (anonymous-init-method env)))))) - -(def: (returnG returnT) - (-> (Type Return) (Bytecode Any)) - (case (type.void? returnT) - (#.Right returnT) - _.return - - (#.Left returnT) - (case (type.primitive? returnT) - (#.Left returnT) - ($_ _.compose - (_.checkcast returnT) - _.areturn) - - (#.Right returnT) - (cond (or (:: type.equivalence = type.boolean returnT) - (:: type.equivalence = type.byte returnT) - (:: type.equivalence = type.short returnT) - (:: type.equivalence = type.int returnT) - (:: type.equivalence = type.char returnT)) - _.ireturn - - (:: type.equivalence = type.long returnT) - _.lreturn - - (:: type.equivalence = type.float returnT) - _.freturn - - ## (:: type.equivalence = type.double returnT) - _.dreturn)))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - .text - ..class - (.tuple (<>.some ..class)) - (.tuple (<>.some ..input)) - (.tuple (<>.some ..overriden-method-definition))) - (function (_ extension-name generate [class-name - super-class super-interfaces - inputsTS - overriden-methods]) - (do /////.monad - [#let [class (type.class class-name (list)) - total-environment (|> overriden-methods - ## Get all the environments. - (list@map product.left) - ## Combine them. - list@join - ## Remove duplicates. - (set.from-list //////reference.hash) - set.to-list) - global-mapping (|> total-environment - ## Give them names as "foreign" variables. - list.enumerate - (list@map (function (_ [id capture]) - [capture (#//////reference.Foreign id)])) - (dictionary.from-list //////reference.hash)) - normalized-methods (list@map (function (_ [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]]) - (let [local-mapping (|> environment - list.enumerate - (list@map (function (_ [foreign-id capture]) - [(#//////reference.Foreign foreign-id) - (|> global-mapping - (dictionary.get capture) - maybe.assume)])) - (dictionary.from-list //////reference.hash))] - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - (normalize-method-body local-mapping body)])) - overriden-methods)] - inputsTI (monad.map @ (generate-input generate) inputsTS) - method-definitions (monad.map @ (function (_ [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - bodyS]) - (do @ - [bodyG (//////generation.with-specific-context class-name - (generate bodyS))] - (wrap (method.method ($_ modifier@compose - method.public - method.final - (if strict-fp? - method.strict - modifier@identity)) - name - (type.method [(list@map product.right arguments) - returnT - exceptionsT]) - (list) - (#.Some ($_ _.compose - bodyG - (returnG returnT))))))) - normalized-methods) - bytecode (<| (:: @ map (format.run class.writer)) - /////.lift - (class.class version.v6_0 ($_ modifier@compose class.public class.final) - (name.internal class-name) - (name.internal (..reflection super-class)) - (list@map (|>> ..reflection name.internal) super-interfaces) - (foreign.variables total-environment) - (list& (..with-anonymous-init class total-environment super-class inputsTI) - method-definitions) - (row.row))) - _ (//////generation.save! true ["" class-name] [class-name bytecode])] - (anonymous-instance class total-environment)))])) - -(def: bundle::class - Bundle - (<| (/////bundle.prefix "class") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "anonymous" class::anonymous) - ))) - -(def: #export bundle - Bundle - (<| (/////bundle.prefix "jvm") - (|> ..bundle::conversion - (dictionary.merge ..bundle::int) - (dictionary.merge ..bundle::long) - (dictionary.merge ..bundle::float) - (dictionary.merge ..bundle::double) - (dictionary.merge ..bundle::char) - (dictionary.merge ..bundle::array) - (dictionary.merge ..bundle::object) - (dictionary.merge ..bundle::member) - (dictionary.merge ..bundle::class) - ))) -- cgit v1.2.3