diff options
Diffstat (limited to '')
4 files changed, 1088 insertions, 4 deletions
diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux index 49b4c0297..d21cbc1c2 100644 --- a/stdlib/source/lux/target/jvm/type/alias.lux +++ b/stdlib/source/lux/target/jvm/type/alias.lux @@ -12,7 +12,6 @@ ["." text ["%" format (#+ format)]] [collection - [array (#+ Array)] ["." dictionary (#+ Dictionary)]]]] ["." // (#+ Type) [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index 8202fd101..c4481998e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Type primitive type char int) + [lux (#- Type Module primitive type char int) ["." host (#+ import:)] ["." macro] [abstract diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux index b7cc9c9fe..d436d1974 100644 --- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux @@ -5,7 +5,7 @@ ["." dictionary]]]] ["." / #_ ["#." common] - ## ["#." host] + ["#." host] [// [runtime (#+ Bundle)]]]) @@ -13,5 +13,5 @@ Bundle ($_ dictionary.merge /common.bundle - ## /host.bundle + /host.bundle )) 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 new file mode 100644 index 000000000..7b14d2c07 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux @@ -0,0 +1,1085 @@ +(.module: + [lux (#- Type) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser + ["<t>" text] + ["<s>" 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]]] + ["/#" // + [analysis (#+ Environment)] + ["#." reference (#+ Variable)] + ["#." synthesis (#+ Synthesis Path %synthesis)]]]]]) + +(template [<name> <0> <1>] + [(def: <name> + (Bytecode Any) + ($_ _.compose + <0> + <1>))] + + [l2s _.l2i _.i2s] + [l2b _.l2i _.i2b] + [l2c _.l2i _.i2c] + ) + +(template [<conversion> <name>] + [(def: (<name> inputG) + (Unary (Bytecode Any)) + (if (is? _.nop <conversion>) + inputG + ($_ _.compose + inputG + <conversion>)))] + + [_.d2f conversion::double-to-float] + [_.d2i conversion::double-to-int] + [_.d2l conversion::double-to-long] + [_.f2d conversion::float-to-double] + [_.f2i conversion::float-to-int] + [_.f2l conversion::float-to-long] + [_.i2b conversion::int-to-byte] + [_.i2c conversion::int-to-char] + [_.i2d conversion::int-to-double] + [_.i2f conversion::int-to-float] + [_.i2l conversion::int-to-long] + [_.i2s conversion::int-to-short] + [_.l2d conversion::long-to-double] + [_.l2f conversion::long-to-float] + [_.l2i conversion::long-to-int] + [..l2s conversion::long-to-short] + [..l2b conversion::long-to-byte] + [..l2c conversion::long-to-char] + [_.i2b conversion::char-to-byte] + [_.i2s conversion::char-to-short] + [_.nop conversion::char-to-int] + [_.i2l conversion::char-to-long] + [_.i2l conversion::byte-to-long] + [_.i2l conversion::short-to-long] + ) + +(def: 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 [<name> <op>] + [(def: (<name> [xG yG]) + (Binary (Bytecode Any)) + ($_ _.compose + xG + yG + <op>))] + + [int::+ _.iadd] + [int::- _.isub] + [int::* _.imul] + [int::/ _.idiv] + [int::% _.irem] + [int::and _.iand] + [int::or _.ior] + [int::xor _.ixor] + [int::shl _.ishl] + [int::shr _.ishr] + [int::ushr _.iushr] + + [long::+ _.ladd] + [long::- _.lsub] + [long::* _.lmul] + [long::/ _.ldiv] + [long::% _.lrem] + [long::and _.land] + [long::or _.lor] + [long::xor _.lxor] + [long::shl _.lshl] + [long::shr _.lshr] + [long::ushr _.lushr] + + [float::+ _.fadd] + [float::- _.fsub] + [float::* _.fmul] + [float::/ _.fdiv] + [float::% _.frem] + + [double::+ _.dadd] + [double::- _.dsub] + [double::* _.dmul] + [double::/ _.ddiv] + [double::% _.drem] + ) + +(def: $Boolean (type.class box.boolean (list))) +(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean)) +(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean)) + +(template [<name> <op>] + [(def: (<name> [xG yG]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + xG + yG + (<op> @then) + falseG + (_.goto @end) + (_.set-label @then) + trueG + (_.set-label @end))))] + + [int::= _.if-icmpeq] + [int::< _.if-icmplt] + + [char::= _.if-icmpeq] + [char::< _.if-icmplt] + ) + +(template [<name> <op> <reference>] + [(def: (<name> [xG yG]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new-label + @end _.new-label] + ($_ _.compose + xG + yG + <op> + (_.int (i32.i32 (.i64 <reference>))) + (_.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 [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <s>.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 (<t>.embed parser.array <s>.text)] + (case (parser.array? arrayJT) + (#.Some elementJT) + (case (parser.object? elementJT) + (#.Some elementJT) + (wrap elementJT) + + #.None + (<>.fail (exception.construct ..not-an-object-array arrayJT))) + + #.None + (undefined)))) + +(def: (primitive-array-length-handler jvm-primitive) + (-> (Type Primitive) Handler) + (..custom + [<s>.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 <s>.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 + [<s>.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 <s>.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 <s>.any <s>.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 <s>.any <s>.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 <s>.any <s>.any <s>.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 <s>.any <s>.any <s>.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 + [<s>.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 <s>.text <s>.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 <s>.text <s>.text <s>.any) + (function (_ extension-name generate [from to valueS]) + (do /////.monad + [valueG (generate valueS)] + (wrap (`` (cond (~~ (template [<object> <type> <unwrap>] + [(and (text@= (..reflection <type>) + from) + (text@= <object> + to)) + (let [$<object> (type.class <object> (list))] + ($_ _.compose + valueG + (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)])))) + + (and (text@= <object> + from) + (text@= (..reflection <type>) + to)) + (let [$<object> (type.class <object> (list))] + ($_ _.compose + valueG + (_.checkcast $<object>) + (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (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 <s>.text <s>.text <s>.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 <s>.text <s>.text <s>.text <s>.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 <s>.text <s>.text <s>.text <s>.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 <s>.text <s>.text <s>.text <s>.any <s>.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) + (<s>.tuple (<>.and ..value <s>.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 <s>.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 [<name> <invoke>] + [(def: <name> + Handler + (..custom + [($_ <>.and ..class <s>.text ..return <s>.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) + (<invoke> 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 "<init>" (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)) + (<s>.tuple (<>.and <s>.text <s>.any))) + +(def: annotation + (Parser (/.Annotation Synthesis)) + (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) + +(def: argument + (Parser Argument) + (<s>.tuple (<>.and <s>.text ..value))) + +(def: overriden-method-definition + (Parser [Environment (/.Overriden-Method Synthesis)]) + (<s>.tuple (do <>.monad + [_ (<s>.text! /.overriden-tag) + ownerT ..class + name <s>.text + strict-fp? <s>.bit + annotations (<s>.tuple (<>.some ..annotation)) + vars (<s>.tuple (<>.some ..var)) + self-name <s>.text + arguments (<s>.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (<s>.tuple (<>.some ..class)) + [environment body] (<s>.function 1 + (<s>.tuple <s>.any))] + (wrap [environment + [ownerT name + strict-fp? annotations vars + self-name arguments returnT exceptionsT + body]])))) + +(def: (normalize-path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (recur path) + (case path + (^ (//////synthesis.path/then bodyS)) + (//////synthesis.path/then (normalize bodyS)) + + (^template [<tag>] + (^ (<tag> leftP rightP)) + (<tag> (recur leftP) (recur rightP))) + ([#//////synthesis.Alt] + [#//////synthesis.Seq]) + + (^template [<tag>] + (^ (<tag> value)) + path) + ([#//////synthesis.Pop] + [#//////synthesis.Test] + [#//////synthesis.Bind] + [#//////synthesis.Access])))) + +(def: (normalize-method-body mapping) + (-> (Dictionary Variable Variable) Synthesis Synthesis) + (function (recur body) + (case body + (^template [<tag>] + (^ (<tag> value)) + body) + ([#//////synthesis.Primitive] + [//////synthesis.constant]) + + (^ (//////synthesis.variant [lefts right? sub])) + (//////synthesis.variant [lefts right? (recur sub)]) + + (^ (//////synthesis.tuple members)) + (//////synthesis.tuple (list@map recur members)) + + (^ (//////synthesis.variable var)) + (|> mapping + (dictionary.get var) + (maybe.default var) + //////synthesis.variable) + + (^ (//////synthesis.branch/case [inputS pathS])) + (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) + + (^ (//////synthesis.branch/let [inputS register outputS])) + (//////synthesis.branch/let [(recur inputS) register (recur outputS)]) + + (^ (//////synthesis.branch/if [testS thenS elseS])) + (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) + + (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) + (//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + + (^ (//////synthesis.loop/recur updatesS+)) + (//////synthesis.loop/recur (list@map recur updatesS+)) + + (^ (//////synthesis.function/abstraction [environment arity bodyS])) + (//////synthesis.function/abstraction [(|> environment (list@map (function (_ local) + (|> mapping + (dictionary.get local) + (maybe.default local))))) + arity + bodyS]) + + (^ (//////synthesis.function/apply [functionS inputsS+])) + (//////synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + + (#//////synthesis.Extension [name inputsS+]) + (#//////synthesis.Extension [name (list@map recur inputsS+)])))) + +(def: $Object (type.class "java.lang.Object" (list))) + +(def: (anonymous-init-method env) + (-> Environment (Type 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 "<init>" (anonymous-init-method env) + (list) + (#.Some ($_ _.compose + (_.aload 0) + (monad.map _.monad product.right inputsTG) + (_.invokespecial super-class "<init>" (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 "<init>" (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 + <s>.text + ..class + (<s>.tuple (<>.some ..class)) + (<s>.tuple (<>.some ..input)) + (<s>.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) + ))) |