diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/runtime.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/runtime.jvm.lux | 603 |
1 files changed, 0 insertions, 603 deletions
diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux deleted file mode 100644 index df494a904..000000000 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ /dev/null @@ -1,603 +0,0 @@ -(.module: - lux - (lux (control monad) - (data text/format - (coll [list "list/" Functor<List>])) - [math] - [macro]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["$i" inst])) - ["la" analysis] - ["ls" synthesis] - (translation [".T" common])))) - -(def: $Object $.Type ($t.class "java.lang.Object" (list))) -(def: $Object-Array $.Type ($t.array +1 $Object)) -(def: $String $.Type ($t.class "java.lang.String" (list))) -(def: #export $Stack $.Type ($t.array +1 $Object)) -(def: #export $Tuple $.Type $Object-Array) -(def: #export $Variant $.Type $Object-Array) -(def: #export $Tag $.Type $t.int) -(def: #export $Flag $.Type $Object) -(def: #export $Datum $.Type $Object) -(def: #export $Function $.Type ($t.class hostL.function-class (list))) -(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list))) - -(def: #export logI - $.Inst - (let [outI ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) - printI (function [method] ($i.INVOKEVIRTUAL "java.io.PrintStream" method ($t.method (list $Object) #.None (list)) false))] - (|>> outI ($i.string "LOG: ") (printI "print") - outI $i.SWAP (printI "println")))) - -(def: variant-method - $.Method - ($t.method (list $t.int $Object $Object) (#.Some $Object-Array) (list))) - -(def: #export variantI - $.Inst - ($i.INVOKESTATIC hostL.runtime-class "variant_make" variant-method false)) - -(def: #export leftI - $.Inst - (|>> ($i.int 0) - $i.NULL - $i.DUP2_X1 - $i.POP2 - variantI)) - -(def: #export rightI - $.Inst - (|>> ($i.int 1) - ($i.string "") - $i.DUP2_X1 - $i.POP2 - variantI)) - -(def: #export someI $.Inst rightI) - -(def: #export noneI - $.Inst - (|>> ($i.int 0) - $i.NULL - ($i.string hostL.unit) - variantI)) - -(def: (try-methodI unsafeI) - (-> $.Inst $.Inst) - (<| $i.with-label (function [@from]) - $i.with-label (function [@to]) - $i.with-label (function [@handler]) - (|>> ($i.try @from @to @handler "java.lang.Exception") - ($i.label @from) - unsafeI - someI - $i.ARETURN - ($i.label @to) - ($i.label @handler) - noneI - $i.ARETURN))) - -(def: #export string-concatI - $.Inst - ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false)) - -(def: #export partials-field Text "partials") -(def: #export apply-method Text "apply") -(def: #export num-apply-variants Nat +8) - -(def: #export (apply-signature arity) - (-> ls.Arity $.Method) - ($t.method (list.repeat arity $Object) (#.Some $Object) (list))) - -(def: adt-methods - $.Def - (let [store-tagI (|>> $i.DUP ($i.int 0) ($i.ILOAD +0) ($i.wrap #$.Int) $i.AASTORE) - store-flagI (|>> $i.DUP ($i.int 1) ($i.ALOAD +1) $i.AASTORE) - store-valueI (|>> $i.DUP ($i.int 2) ($i.ALOAD +2) $i.AASTORE) - force-textMT ($t.method (list $Object) (#.Some $String) (list))] - (|>> ($d.method #$.Public $.staticM "force_text" force-textMT - (<| $i.with-label (function [@is-null]) - $i.with-label (function [@normal-object]) - $i.with-label (function [@array-loop]) - $i.with-label (function [@within-bounds]) - $i.with-label (function [@is-first]) - $i.with-label (function [@elem-end]) - $i.with-label (function [@fold-end]) - (let [on-normal-objectI (|>> ($i.ALOAD +0) - ($i.INVOKEVIRTUAL "java.lang.Object" "toString" ($t.method (list) (#.Some $String) (list)) false)) - on-null-objectI ($i.string "NULL") - arrayI (|>> ($i.ALOAD +0) - ($i.CHECKCAST ($t.descriptor $Object-Array))) - recurseI ($i.INVOKESTATIC hostL.runtime-class "force_text" force-textMT false) - force-elemI (|>> $i.DUP arrayI $i.SWAP $i.AALOAD recurseI) - swap2 (|>> $i.DUP2_X2 ## X,Y => Y,X,Y - $i.POP2 ## Y,X,Y => Y,X - ) - add-spacingI (|>> ($i.string ", ") $i.SWAP string-concatI) - merge-with-totalI (|>> $i.DUP_X2 $i.POP ## TSIP => TPSI - swap2 ## TPSI => SITP - string-concatI ## SITP => SIT - $i.DUP_X2 $i.POP ## SIT => TSI - ) - foldI (|>> $i.DUP ## TSI => TSII - ($i.IFEQ @is-first) ## TSI - force-elemI add-spacingI merge-with-totalI ($i.GOTO @elem-end) - ($i.label @is-first) ## TSI - force-elemI merge-with-totalI - ($i.label @elem-end) ## TSI - ) - inc-idxI (|>> ($i.int 1) $i.IADD) - on-array-objectI (|>> ($i.string "[") ## T - arrayI $i.ARRAYLENGTH ## TS - ($i.int 0) ## TSI - ($i.label @array-loop) ## TSI - $i.DUP2 - ($i.IF_ICMPGT @within-bounds) ## TSI - $i.POP2 ($i.string "]") string-concatI ($i.GOTO @fold-end) - ($i.label @within-bounds) - foldI inc-idxI ($i.GOTO @array-loop) - ($i.label @fold-end))]) - (|>> ($i.ALOAD +0) - ($i.IFNULL @is-null) - ($i.ALOAD +0) - ($i.INSTANCEOF ($t.descriptor $Object-Array)) - ($i.IFEQ @normal-object) - on-array-objectI $i.ARETURN - ($i.label @normal-object) on-normal-objectI $i.ARETURN - ($i.label @is-null) on-null-objectI $i.ARETURN))) - ($d.method #$.Public $.staticM "variant_make" - ($t.method (list $t.int $Object $Object) - (#.Some $Variant) - (list)) - (|>> ($i.int 3) - ($i.array $Object) - store-tagI - store-flagI - store-valueI - $i.ARETURN))))) - -(def: #export force-textI - $.Inst - ($i.INVOKESTATIC hostL.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) false)) - -(def: nat-methods - $.Def - (let [compare-nat-method ($t.method (list $t.long $t.long) (#.Some $t.int) (list)) - less-thanI (function [@where] (|>> ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false) ($i.IFLT @where))) - $BigInteger ($t.class "java.math.BigInteger" (list)) - upcast-method ($t.method (list $t.long) (#.Some $BigInteger) (list)) - div-method ($t.method (list $t.long $t.long) (#.Some $t.long) (list)) - upcastI ($i.INVOKESTATIC hostL.runtime-class "_toUnsignedBigInteger" upcast-method false) - downcastI ($i.INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t.method (list) (#.Some $t.long) (list)) false)] - (|>> ($d.method #$.Public $.staticM "_toUnsignedBigInteger" upcast-method - (let [upcastI ($i.INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) - discernI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGE @where))) - prepare-upperI (|>> ($i.LLOAD +0) ($i.int 32) $i.LUSHR - upcastI - ($i.int 32) ($i.INVOKEVIRTUAL "java.math.BigInteger" "shiftLeft" ($t.method (list $t.int) (#.Some $BigInteger) (list)) false)) - prepare-lowerI (|>> ($i.LLOAD +0) ($i.int 32) $i.LSHL - ($i.int 32) $i.LUSHR - upcastI)] - (<| $i.with-label (function [@simple]) - (|>> (discernI @simple) - ## else - prepare-upperI - prepare-lowerI - ($i.INVOKEVIRTUAL "java.math.BigInteger" "add" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false) - $i.ARETURN - ## then - ($i.label @simple) - ($i.LLOAD +0) - upcastI - $i.ARETURN)))) - ($d.method #$.Public $.staticM "compare_nat" compare-nat-method - (let [shiftI (|>> ($i.GETSTATIC "java.lang.Long" "MIN_VALUE" $t.long) $i.LADD)] - (|>> ($i.LLOAD +0) shiftI - ($i.LLOAD +2) shiftI - $i.LCMP - $i.IRETURN))) - ($d.method #$.Public $.staticM "div_nat" div-method - (let [is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLT @where))) - is-subject-smallI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFGT @where))) - small-division (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LDIV $i.LRETURN) - big-divisionI ($i.INVOKEVIRTUAL "java.math.BigInteger" "divide" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] - (<| $i.with-label (function [@is-zero]) - $i.with-label (function [@param-is-large]) - $i.with-label (function [@subject-is-small]) - (|>> (is-param-largeI @param-is-large) - ## Param is not too large - (is-subject-smallI @subject-is-small) - ## Param is small, but subject is large - ($i.LLOAD +0) upcastI - ($i.LLOAD +2) upcastI - big-divisionI downcastI $i.LRETURN - ## Both param and subject are small, - ## and can thus be divided normally. - ($i.label @subject-is-small) - small-division - ## Param is too large. Cannot simply divide. - ## Depending on the result of the - ## comparison, a result will be determined. - ($i.label @param-is-large) - ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @is-zero) - ## Greater-than or equals - ($i.long 1) $i.LRETURN - ## Less than - ($i.label @is-zero) - ($i.long 0) $i.LRETURN)))) - ($d.method #$.Public $.staticM "rem_nat" div-method - (let [is-subject-largeI (function [@where] (|>> ($i.LLOAD +0) ($i.long 0) $i.LCMP ($i.IFLE @where))) - is-param-largeI (function [@where] (|>> ($i.LLOAD +2) ($i.long 0) $i.LCMP ($i.IFLE @where))) - small-remainderI (|>> ($i.LLOAD +0) ($i.LLOAD +2) $i.LREM $i.LRETURN) - big-remainderI ($i.INVOKEVIRTUAL "java.math.BigInteger" "remainder" ($t.method (list $BigInteger) (#.Some $BigInteger) (list)) false)] - (<| $i.with-label (function [@large-number]) - $i.with-label (function [@subject-is-smaller-than-param]) - (|>> (is-subject-largeI @large-number) - (is-param-largeI @large-number) - small-remainderI - - ($i.label @large-number) - ($i.LLOAD +0) ($i.LLOAD +2) (less-thanI @subject-is-smaller-than-param) - - ($i.LLOAD +0) upcastI - ($i.LLOAD +2) upcastI - big-remainderI downcastI $i.LRETURN - - ($i.label @subject-is-smaller-than-param) - ($i.LLOAD +0) - $i.LRETURN)))) - ))) - -(def: frac-shiftI $.Inst ($i.double (math.pow 32.0 2.0))) - -(def: frac-methods - $.Def - (|>> ($d.method #$.Public $.staticM "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) - (try-methodI - (|>> ($i.ALOAD +0) - ($i.INVOKESTATIC "java.lang.Double" "parseDouble" ($t.method (list $String) (#.Some $t.double) (list)) false) - ($i.wrap #$.Double)))) - ($d.method #$.Public $.staticM "frac_to_deg" ($t.method (list $t.double) (#.Some $t.long) (list)) - (let [swap2 (|>> $i.DUP2_X2 $i.POP2) - drop-excessI (|>> ($i.double 1.0) $i.DREM) - shiftI (|>> frac-shiftI $i.DMUL)] - (|>> ($i.DLOAD +0) - ## Get upper half - drop-excessI - shiftI - ## Make a copy, so the lower half can be extracted - $i.DUP2 - ## Get lower half - drop-excessI - shiftI - ## Turn it into a deg - $i.D2L - ## Turn the upper half into deg too - swap2 - $i.D2L - ## Combine both pieces - $i.LADD - ## FINISH - $i.LRETURN - ))) - )) - -(def: deg-bits Nat +64) -(def: deg-method $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) -(def: clz-method $.Method ($t.method (list $t.long) (#.Some $t.int) (list))) - -(def: deg-methods - $.Def - (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. - low-half (|>> ($i.int -1) $i.I2L $i.LAND) - high-half (|>> ($i.int 32) $i.LUSHR)] - (|>> ($d.method #$.Public $.staticM "mul_deg" deg-method - ## Based on: http://stackoverflow.com/a/31629280/6823464 - (let [shift-downI (|>> ($i.int 32) $i.LUSHR) - low-leftI (|>> ($i.LLOAD +0) low-half) - high-leftI (|>> ($i.LLOAD +0) high-half) - low-rightI (|>> ($i.LLOAD +2) low-half) - high-rightI (|>> ($i.LLOAD +2) high-half) - bottomI (|>> low-leftI low-rightI $i.LMUL) - middleLI (|>> high-leftI low-rightI $i.LMUL) - middleRI (|>> low-leftI high-rightI $i.LMUL) - middleI (|>> middleLI middleRI $i.LADD) - topI (|>> high-leftI high-rightI $i.LMUL)] - (|>> bottomI shift-downI - middleI $i.LADD shift-downI - topI $i.LADD - $i.LRETURN))) - ($d.method #$.Public $.staticM "count_leading_zeros" clz-method - (let [when-zeroI (function [@where] (|>> ($i.long 0) $i.LCMP ($i.IFEQ @where))) - shift-rightI (function [amount] (|>> ($i.int amount) $i.LUSHR)) - decI (|>> ($i.int 1) $i.ISUB)] - (<| $i.with-label (function [@start]) - $i.with-label (function [@done]) - (|>> ($i.int 64) - ($i.label @start) - ($i.LLOAD +0) (when-zeroI @done) - ($i.LLOAD +0) (shift-rightI 1) ($i.LSTORE +0) - decI - ($i.GOTO @start) - ($i.label @done) - $i.IRETURN)))) - ($d.method #$.Public $.staticM "div_deg" deg-method - (<| $i.with-label (function [@same]) - (let [subjectI ($i.LLOAD +0) - paramI ($i.LLOAD +2) - equal?I (function [@where] (|>> $i.LCMP ($i.IFEQ @where))) - count-leading-zerosI ($i.INVOKESTATIC hostL.runtime-class "count_leading_zeros" clz-method false) - calc-max-shiftI (|>> subjectI count-leading-zerosI - paramI count-leading-zerosI - ($i.INVOKESTATIC "java.lang.Math" "min" ($t.method (list $t.int $t.int) (#.Some $t.int) (list)) false) - ($i.ISTORE +4)) - shiftI (|>> ($i.ILOAD +4) $i.LSHL) - imprecise-divisionI (|>> subjectI shiftI - paramI shiftI high-half - $i.LDIV) - scale-downI (|>> ($i.int 32) $i.LSHL)] - (|>> subjectI paramI - (equal?I @same) - ## Based on: http://stackoverflow.com/a/8510587/6823464 - ## Shifting the operands as much as possible can help - ## avoid some loss of precision later. - calc-max-shiftI - imprecise-divisionI - scale-downI - $i.LRETURN - ($i.label @same) - ($i.long -1) ## ~= 1.0 Degrees - $i.LRETURN)))) - ($d.method #$.Public $.staticM "deg_to_frac" ($t.method (list $t.long) (#.Some $t.double) (list)) - (let [highI (|>> ($i.LLOAD +0) high-half $i.L2D) - lowI (|>> ($i.LLOAD +0) low-half $i.L2D) - scaleI (|>> frac-shiftI $i.DDIV)] - (|>> highI scaleI - lowI scaleI scaleI - $i.DADD - $i.DRETURN))) - ))) - -(def: text-methods - $.Def - (|>> ($d.method #$.Public $.staticM "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) - (try-methodI - (|>> ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.ILOAD +2) - ($i.INVOKEVIRTUAL "java.lang.String" "substring" ($t.method (list $t.int $t.int) (#.Some $String) (list)) false)))) - ($d.method #$.Public $.staticM "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) - (try-methodI - (|>> ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.INVOKEVIRTUAL "java.lang.String" "codePointAt" ($t.method (list $t.int) (#.Some $t.int) (list)) false) - $i.I2L - ($i.wrap #$.Long)))) - )) - -(def: pm-methods - $.Def - (let [tuple-sizeI (|>> ($i.ALOAD +0) $i.ARRAYLENGTH) - tuple-elemI (|>> ($i.ALOAD +0) ($i.ILOAD +1) $i.AALOAD) - expected-last-sizeI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD) - tuple-tailI (|>> ($i.ALOAD +0) tuple-sizeI ($i.int 1) $i.ISUB $i.AALOAD ($i.CHECKCAST ($t.descriptor $Tuple)))] - (|>> ($d.method #$.Public $.staticM "pm_fail" ($t.method (list) #.None (list)) - (|>> ($i.NEW "java.lang.IllegalStateException") - $i.DUP - ($i.string "Invalid expression for pattern-matching.") - ($i.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) false) - $i.ATHROW)) - ($d.method #$.Public $.staticM "apply_fail" ($t.method (list) #.None (list)) - (|>> ($i.NEW "java.lang.IllegalStateException") - $i.DUP - ($i.string "Error while applying function.") - ($i.INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t.method (list $String) #.None (list)) false) - $i.ATHROW)) - ($d.method #$.Public $.staticM "pm_push" ($t.method (list $Stack $Object) (#.Some $Stack) (list)) - (|>> ($i.int 2) - ($i.ANEWARRAY "java.lang.Object") - $i.DUP - ($i.int 0) - ($i.ALOAD +0) - $i.AASTORE - $i.DUP - ($i.int 1) - ($i.ALOAD +1) - $i.AASTORE - $i.ARETURN)) - ($d.method #$.Public $.staticM "pm_pop" ($t.method (list $Stack) (#.Some $Stack) (list)) - (|>> ($i.ALOAD +0) - ($i.int 0) - $i.AALOAD - ($i.CHECKCAST ($t.descriptor $Stack)) - $i.ARETURN)) - ($d.method #$.Public $.staticM "pm_peek" ($t.method (list $Stack) (#.Some $Object) (list)) - (|>> ($i.ALOAD +0) - ($i.int 1) - $i.AALOAD - $i.ARETURN)) - ($d.method #$.Public $.staticM "pm_variant" ($t.method (list $Variant $Tag $Flag) (#.Some $Object) (list)) - (<| $i.with-label (function [@begin]) - $i.with-label (function [@just-return]) - $i.with-label (function [@then]) - $i.with-label (function [@further]) - $i.with-label (function [@shorten]) - $i.with-label (function [@wrong]) - (let [variant-partI (: (-> Nat $.Inst) - (function [idx] - (|>> ($i.int (nat-to-int idx)) $i.AALOAD))) - tagI (: $.Inst - (|>> (variant-partI +0) ($i.unwrap #$.Int))) - flagI (variant-partI +1) - datumI (variant-partI +2) - shortenI (|>> ($i.ALOAD +0) tagI ## Get tag - ($i.ILOAD +1) $i.ISUB ## Shorten tag - ($i.ALOAD +0) flagI ## Get flag - ($i.ALOAD +0) datumI ## Get value - variantI ## Build sum - $i.ARETURN) - update-tagI (|>> $i.ISUB ($i.ISTORE +1)) - update-variantI (|>> ($i.ALOAD +0) datumI ($i.CHECKCAST ($t.descriptor $Variant)) ($i.ASTORE +0)) - failureI (|>> $i.NULL $i.ARETURN) - return-datumI (|>> ($i.ALOAD +0) datumI $i.ARETURN)]) - (|>> ($i.label @begin) - ($i.ILOAD +1) ## tag - ($i.ALOAD +0) tagI ## tag, sumT - $i.DUP2 ($i.IF_ICMPEQ @then) - $i.DUP2 ($i.IF_ICMPGT @further) - $i.DUP2 ($i.IF_ICMPLT @shorten) - ## $i.POP2 - failureI - ($i.label @then) ## tag, sumT - ($i.ALOAD +2) ## tag, sumT, wants-last? - ($i.ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? - ($i.IF_ACMPEQ @just-return) ## tag, sumT - ($i.label @further) ## tag, sumT - ($i.ALOAD +0) flagI ## tag, sumT, last? - ($i.IFNULL @wrong) ## tag, sumT - update-tagI - update-variantI - ($i.GOTO @begin) - ($i.label @just-return) ## tag, sumT - ## $i.POP2 - return-datumI - ($i.label @shorten) ## tag, sumT - ($i.ALOAD +2) ($i.IFNULL @wrong) - ## $i.POP2 - shortenI - ($i.label @wrong) ## tag, sumT - ## $i.POP2 - failureI))) - ($d.method #$.Public $.staticM "pm_left" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) - (<| $i.with-label (function [@begin]) - $i.with-label (function [@not-recursive]) - (let [updated-idxI (|>> $i.SWAP $i.ISUB)]) - (|>> ($i.label @begin) - tuple-sizeI - expected-last-sizeI - $i.DUP2 ($i.IF_ICMPGT @not-recursive) - ## Recursive - updated-idxI ($i.ISTORE +1) - tuple-tailI ($i.ASTORE +0) - ($i.GOTO @begin) - ($i.label @not-recursive) - ## $i.POP2 - tuple-elemI - $i.ARETURN))) - ($d.method #$.Public $.staticM "pm_right" ($t.method (list $Tuple $t.int) (#.Some $Object) (list)) - (<| $i.with-label (function [@begin]) - $i.with-label (function [@tail]) - $i.with-label (function [@slice]) - (let [updated-idxI (|>> ($i.ILOAD +1) ($i.int 1) $i.IADD tuple-sizeI $i.ISUB) - sliceI (|>> ($i.ALOAD +0) ($i.ILOAD +1) tuple-sizeI - ($i.INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t.method (list $Object-Array $t.int $t.int) (#.Some $Object-Array) (list)) false))]) - (|>> ($i.label @begin) - tuple-sizeI - expected-last-sizeI - $i.DUP2 ($i.IF_ICMPEQ @tail) - ($i.IF_ICMPGT @slice) - ## Must recurse - tuple-tailI ($i.ASTORE +0) - updated-idxI ($i.ISTORE +1) - ($i.GOTO @begin) - ($i.label @slice) - sliceI - $i.ARETURN - ($i.label @tail) - ## $i.POP2 - tuple-elemI - $i.ARETURN))) - ))) - -(def: io-methods - $.Def - (let [string-writerI (|>> ($i.NEW "java.io.StringWriter") - $i.DUP - ($i.INVOKESPECIAL "java.io.StringWriter" "<init>" ($t.method (list) #.None (list)) false)) - print-writerI (|>> ($i.NEW "java.io.PrintWriter") - $i.SWAP - $i.DUP2 - $i.POP - $i.SWAP - ($i.boolean true) - ($i.INVOKESPECIAL "java.io.PrintWriter" "<init>" ($t.method (list ($t.class "java.io.Writer" (list)) $t.boolean) #.None (list)) false) - )] - (|>> ($d.method #$.Public $.staticM "try" ($t.method (list $Function) (#.Some $Variant) (list)) - (<| $i.with-label (function [@from]) - $i.with-label (function [@to]) - $i.with-label (function [@handler]) - (|>> ($i.try @from @to @handler "java.lang.Throwable") - ($i.label @from) - ($i.ALOAD +0) - $i.NULL - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) - rightI - $i.ARETURN - ($i.label @to) - ($i.label @handler) - string-writerI ## TW - $i.DUP2 ## TWTW - print-writerI ## TWTP - ($i.INVOKEVIRTUAL "java.lang.Throwable" "printStackTrace" ($t.method (list ($t.class "java.io.PrintWriter" (list))) #.None (list)) false) ## TW - ($i.INVOKEVIRTUAL "java.io.StringWriter" "toString" ($t.method (list) (#.Some $String) (list)) false) ## TS - $i.SWAP $i.POP leftI - $i.ARETURN))) - ))) - -(def: translate-runtime - (Meta commonT.Bytecode) - (do macro.Monad<Meta> - [_ (wrap []) - #let [bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runtime-class (list) ["java.lang.Object" (list)] (list) - (|>> adt-methods - nat-methods - frac-methods - deg-methods - text-methods - pm-methods - io-methods))] - _ (commonT.store-class hostL.runtime-class bytecode)] - (wrap bytecode))) - -(def: translate-function - (Meta commonT.Bytecode) - (do macro.Monad<Meta> - [_ (wrap []) - #let [applyI (|> (list.n/range +2 num-apply-variants) - (list/map (function [arity] - ($d.method #$.Public $.noneM apply-method (apply-signature arity) - (let [preI (|> (list.n/range +0 (n/dec arity)) - (list/map $i.ALOAD) - $i.fuse)] - (|>> preI - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature (n/dec arity)) false) - ($i.CHECKCAST hostL.function-class) - ($i.ALOAD arity) - ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false) - $i.ARETURN))))) - (list& ($d.abstract-method #$.Public $.noneM apply-method (apply-signature +1))) - $d.fuse) - bytecode ($d.abstract #$.V1_6 #$.Public $.noneC hostL.function-class (list) ["java.lang.Object" (list)] (list) - (|>> ($d.field #$.Public $.finalF partials-field $t.int) - ($d.method #$.Public $.noneM "<init>" ($t.method (list $t.int) #.None (list)) - (|>> ($i.ALOAD +0) - ($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) false) - ($i.ALOAD +0) - ($i.ILOAD +1) - ($i.PUTFIELD hostL.function-class partials-field $t.int) - $i.RETURN)) - applyI))] - _ (commonT.store-class hostL.function-class bytecode)] - (wrap bytecode))) - -(def: #export translate - (Meta [commonT.Bytecode commonT.Bytecode]) - (do macro.Monad<Meta> - [runtime-bc translate-runtime - function-bc translate-function] - (wrap [runtime-bc function-bc]))) |