diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/procedure')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux (renamed from new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux) | 95 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux | 761 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 753 |
3 files changed, 774 insertions, 835 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux index b19287b4e..aeaa1d664 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux @@ -9,22 +9,21 @@ ["." text format] [collection - ["." list ("#/." functor)] ["." dictionary]]] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax:)]] [tool [compiler ["." synthesis (#+ Synthesis)] ["." phase + [generation + [extension (#+ Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)]] ["." extension ["." bundle]]]]] [host (#+ import:)]] [luxc [lang [host - ["$" jvm (#+ Label Inst Method Handler Bundle) + ["$" jvm (#+ Label Inst Method Bundle) ["_t" type] ["_" inst]]]]] ["." /// @@ -34,55 +33,10 @@ (#static MIN_VALUE Double) (#static MAX_VALUE Double)) -## [Types] -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Inst) Inst)) -(type: #export Unary (-> (Vector 1 Inst) Inst)) -(type: #export Binary (-> (Vector 2 Inst) Inst)) -(type: #export Trinary (-> (Vector 3 Inst) Inst)) -(type: #export Variadic (-> (List Inst) Inst)) - -## [Utils] (def: $Object-Array $.Type (_t.array 1 ///.$Object)) (def: $String $.Type (_t.class "java.lang.String" (list))) (def: $CharSequence $.Type (_t.class "java.lang.CharSequence" (list))) -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!extension-name g!phase g!inputs] - (do @ - [g!inputC+ (monad.seq @ (list.repeat arity (macro.gensym "input"))) - #let [arityC (code.nat arity)]] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ arityC) Inst) Inst) ..Handler) - (function ((~ g!_) (~ g!extension-name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!inputC+))) - (do phase.monad - [(~+ (|> g!inputC+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!inputC+)]))) - - (~ g!_) - (phase.fail (ex.construct extension.incorrect-arity - [(~ g!extension-name) (~ arityC) (list.size (~ g!inputs))]))))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name phase inputsS) - (do phase.monad - [inputsH (monad.map @ phase inputsS)] - (wrap (extension inputsH))))) - -## [Instructions] (def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long))) (def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I)) (def: check-stringI Inst (_.CHECKCAST "java.lang.String")) @@ -102,26 +56,23 @@ (def: unitI Inst (_.string synthesis.unit)) -## Extensions -### Lux (def: (lux::is [referenceI sampleI]) - Binary + (Binary Inst) (|>> referenceI sampleI (predicateI _.IF_ACMPEQ))) (def: (lux::try riskyI) - Unary + (Unary Inst) (|>> riskyI (_.CHECKCAST ///.function-class) (_.INVOKESTATIC ///.runtime-class "try" (_t.method (list ///.$Function) (#.Some $Object-Array) (list)) #0))) -### Bits (template [<name> <op>] [(def: (<name> [maskI inputI]) - Binary + (Binary Inst) (|>> inputI (_.unwrap #$.Long) maskI (_.unwrap #$.Long) <op> (_.wrap #$.Long)))] @@ -133,7 +84,7 @@ (template [<name> <op>] [(def: (<name> [shiftI inputI]) - Binary + (Binary Inst) (|>> inputI (_.unwrap #$.Long) shiftI jvm-intI <op> @@ -144,10 +95,9 @@ [bit::logical-right-shift _.LUSHR] ) -### Numbers (template [<name> <const> <type>] [(def: (<name> _) - Nullary + (Nullary Inst) (|>> <const> (_.wrap <type>)))] [frac::smallest (_.double (Double::MIN_VALUE)) #$.Double] @@ -157,7 +107,7 @@ (template [<name> <type> <op>] [(def: (<name> [paramI subjectI]) - Binary + (Binary Inst) (|>> subjectI (_.unwrap <type>) paramI (_.unwrap <type>) <op> @@ -179,7 +129,7 @@ (template [<eq> <lt> <unwrap> <cmp>] [(template [<name> <reference>] [(def: (<name> [paramI subjectI]) - Binary + (Binary Inst) (|>> subjectI <unwrap> paramI <unwrap> <cmp> @@ -195,7 +145,7 @@ (template [<name> <prepare> <transform>] [(def: (<name> inputI) - Unary + (Unary Inst) (|>> inputI <prepare> <transform>))] [int::frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)] @@ -209,9 +159,8 @@ (_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)] ) -### Text (def: (text::size inputI) - Unary + (Unary Inst) (|>> inputI ..check-stringI (_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0) @@ -219,7 +168,7 @@ (template [<name> <pre-subject> <pre-param> <op> <post>] [(def: (<name> [paramI subjectI]) - Binary + (Binary Inst) (|>> subjectI <pre-subject> paramI <pre-param> <op> <post>))] @@ -236,13 +185,13 @@ ) (def: (text::concat [leftI rightI]) - Binary + (Binary Inst) (|>> leftI ..check-stringI rightI ..check-stringI (_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0))) (def: (text::clip [startI endI subjectI]) - Trinary + (Trinary Inst) (|>> subjectI ..check-stringI startI jvm-intI endI jvm-intI @@ -250,7 +199,7 @@ (def: index-method Method (_t.method (list $String _t.int) (#.Some _t.int) (list))) (def: (text::index [startI partI textI]) - Trinary + (Trinary Inst) (<| _.with-label (function (_ @not-found)) _.with-label (function (_ @end)) (|>> textI ..check-stringI @@ -268,10 +217,9 @@ runtime.noneI (_.label @end)))) -### I/O (def: string-method Method (_t.method (list $String) #.None (list))) (def: (io::log messageI) - Unary + (Unary Inst) (|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list))) messageI ..check-stringI @@ -279,7 +227,7 @@ unitI)) (def: (io::error messageI) - Unary + (Unary Inst) (|>> (_.NEW "java.lang.Error") _.DUP messageI @@ -288,17 +236,16 @@ _.ATHROW)) (def: (io::exit codeI) - Unary + (Unary Inst) (|>> codeI jvm-intI (_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0) _.NULL)) (def: (io::current-time _) - Nullary + (Nullary Inst) (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0) (_.wrap #$.Long))) -## Bundles (def: bundle::lux Bundle (|> (: Bundle bundle.empty) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux deleted file mode 100644 index 624af7ed8..000000000 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux +++ /dev/null @@ -1,761 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["p" parser ("#/." monad)] - ["ex" exception #+ exception:]) - (data [product] - ["e" error] - [text ("#/." equivalence)] - (text format - ["l" lexer]) - (coll [list ("#/." functor)] - (dictionary ["dict" unordered #+ Dict]))) - [macro ("#/." monad)] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang [".L" host] - (host ["$" jvm] - (jvm ["$t" type] - ["$d" def] - ["_" inst])) - ["la" analysis] - (extension (analysis ["&." host])) - ["ls" synthesis])) - (// ["@" common])) - -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] - - [Invalid-Syntax-For-JVM-Type] - [Invalid-Syntax-For-Argument-Generation] - ) - -(template [<name> <inst>] - [(def: <name> - $.Inst - <inst>)] - - [L2S (|>> _.L2I _.I2S)] - [L2B (|>> _.L2I _.I2B)] - [L2C (|>> _.L2I _.I2C)] - ) - -(template [<name> <unwrap> <conversion> <wrap>] - [(def: (<name> inputI) - @.Unary - (if (is? _.NOP <conversion>) - (|>> inputI - (_.unwrap <unwrap>) - (_.wrap <wrap>)) - (|>> inputI - (_.unwrap <unwrap>) - <conversion> - (_.wrap <wrap>))))] - - [convert//double-to-float #$.Double _.D2F #$.Float] - [convert//double-to-int #$.Double _.D2I #$.Int] - [convert//double-to-long #$.Double _.D2L #$.Long] - [convert//float-to-double #$.Float _.F2D #$.Double] - [convert//float-to-int #$.Float _.F2I #$.Int] - [convert//float-to-long #$.Float _.F2L #$.Long] - [convert//int-to-byte #$.Int _.I2B #$.Byte] - [convert//int-to-char #$.Int _.I2C #$.Char] - [convert//int-to-double #$.Int _.I2D #$.Double] - [convert//int-to-float #$.Int _.I2F #$.Float] - [convert//int-to-long #$.Int _.I2L #$.Long] - [convert//int-to-short #$.Int _.I2S #$.Short] - [convert//long-to-double #$.Long _.L2D #$.Double] - [convert//long-to-float #$.Long _.L2F #$.Float] - [convert//long-to-int #$.Long _.L2I #$.Int] - [convert//long-to-short #$.Long L2S #$.Short] - [convert//long-to-byte #$.Long L2B #$.Byte] - [convert//long-to-char #$.Long L2C #$.Char] - [convert//char-to-byte #$.Char _.I2B #$.Byte] - [convert//char-to-short #$.Char _.I2S #$.Short] - [convert//char-to-int #$.Char _.NOP #$.Int] - [convert//char-to-long #$.Char _.I2L #$.Long] - [convert//byte-to-long #$.Byte _.I2L #$.Long] - [convert//short-to-long #$.Short _.I2L #$.Long] - ) - -(def: conversion-procs - @.Bundle - (<| (@.prefix "convert") - (|> (dict.new text.hash) - (@.install "double-to-float" (@.unary convert//double-to-float)) - (@.install "double-to-int" (@.unary convert//double-to-int)) - (@.install "double-to-long" (@.unary convert//double-to-long)) - (@.install "float-to-double" (@.unary convert//float-to-double)) - (@.install "float-to-int" (@.unary convert//float-to-int)) - (@.install "float-to-long" (@.unary convert//float-to-long)) - (@.install "int-to-byte" (@.unary convert//int-to-byte)) - (@.install "int-to-char" (@.unary convert//int-to-char)) - (@.install "int-to-double" (@.unary convert//int-to-double)) - (@.install "int-to-float" (@.unary convert//int-to-float)) - (@.install "int-to-long" (@.unary convert//int-to-long)) - (@.install "int-to-short" (@.unary convert//int-to-short)) - (@.install "long-to-double" (@.unary convert//long-to-double)) - (@.install "long-to-float" (@.unary convert//long-to-float)) - (@.install "long-to-int" (@.unary convert//long-to-int)) - (@.install "long-to-short" (@.unary convert//long-to-short)) - (@.install "long-to-byte" (@.unary convert//long-to-byte)) - (@.install "long-to-char" (@.unary convert//long-to-char)) - (@.install "char-to-byte" (@.unary convert//char-to-byte)) - (@.install "char-to-short" (@.unary convert//char-to-short)) - (@.install "char-to-int" (@.unary convert//char-to-int)) - (@.install "char-to-long" (@.unary convert//char-to-long)) - (@.install "byte-to-long" (@.unary convert//byte-to-long)) - (@.install "short-to-long" (@.unary convert//short-to-long)) - ))) - -(template [<name> <op> <unwrapX> <unwrapY> <wrap>] - [(def: (<name> [xI yI]) - @.Binary - (|>> xI (_.unwrap <unwrapX>) - yI (_.unwrap <unwrapY>) - <op> (_.wrap <wrap>)))] - - [int//+ _.IADD #$.Int #$.Int #$.Int] - [int//- _.ISUB #$.Int #$.Int #$.Int] - [int//* _.IMUL #$.Int #$.Int #$.Int] - [int/// _.IDIV #$.Int #$.Int #$.Int] - [int//% _.IREM #$.Int #$.Int #$.Int] - [int//and _.IAND #$.Int #$.Int #$.Int] - [int//or _.IOR #$.Int #$.Int #$.Int] - [int//xor _.IXOR #$.Int #$.Int #$.Int] - [int//shl _.ISHL #$.Int #$.Int #$.Int] - [int//shr _.ISHR #$.Int #$.Int #$.Int] - [int//ushr _.IUSHR #$.Int #$.Int #$.Int] - - [long//+ _.LADD #$.Long #$.Long #$.Long] - [long//- _.LSUB #$.Long #$.Long #$.Long] - [long//* _.LMUL #$.Long #$.Long #$.Long] - [long/// _.LDIV #$.Long #$.Long #$.Long] - [long//% _.LREM #$.Long #$.Long #$.Long] - [long//and _.LAND #$.Long #$.Long #$.Long] - [long//or _.LOR #$.Long #$.Long #$.Long] - [long//xor _.LXOR #$.Long #$.Long #$.Long] - [long//shl _.LSHL #$.Long #$.Int #$.Long] - [long//shr _.LSHR #$.Long #$.Int #$.Long] - [long//ushr _.LUSHR #$.Long #$.Int #$.Long] - - [float//+ _.FADD #$.Float #$.Float #$.Float] - [float//- _.FSUB #$.Float #$.Float #$.Float] - [float//* _.FMUL #$.Float #$.Float #$.Float] - [float/// _.FDIV #$.Float #$.Float #$.Float] - [float//% _.FREM #$.Float #$.Float #$.Float] - - [double//+ _.DADD #$.Double #$.Double #$.Double] - [double//- _.DSUB #$.Double #$.Double #$.Double] - [double//* _.DMUL #$.Double #$.Double #$.Double] - [double/// _.DDIV #$.Double #$.Double #$.Double] - [double//% _.DREM #$.Double #$.Double #$.Double] - ) - -(def: boolean-class ($t.class "java.lang.Boolean" (list))) -(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class)) -(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class)) - -(template [<name> <op> <unwrapX> <unwrapY> <wrap>] - [(def: (<name> [xI yI]) - @.Binary - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI (_.unwrap <unwrapX>) - yI (_.unwrap <unwrapY>) - (<op> @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [int//= _.IF_ICMPEQ #$.Int #$.Int #$.Boolean] - [int//< _.IF_ICMPLT #$.Int #$.Int #$.Boolean] - - [char//= _.IF_ICMPEQ #$.Char #$.Char #$.Boolean] - [char//< _.IF_ICMPLT #$.Char #$.Char #$.Boolean] - ) - -(template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>] - [(def: (<name> [xI yI]) - @.Binary - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> xI (_.unwrap <unwrapX>) - yI (_.unwrap <unwrapY>) - <op> - (_.int <reference>) - (_.IF_ICMPEQ @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end))))] - - [long//= _.LCMP 0 #$.Long #$.Long #$.Boolean] - [long//< _.LCMP -1 #$.Long #$.Long #$.Boolean] - - [float//= _.FCMPG 0 #$.Float #$.Float #$.Boolean] - [float//< _.FCMPG -1 #$.Float #$.Float #$.Boolean] - - [double//= _.DCMPG 0 #$.Double #$.Double #$.Boolean] - [double//< _.DCMPG -1 #$.Double #$.Double #$.Boolean] - ) - -(def: int-procs - @.Bundle - (<| (@.prefix "int") - (|> (dict.new text.hash) - (@.install "+" (@.binary int//+)) - (@.install "-" (@.binary int//-)) - (@.install "*" (@.binary int//*)) - (@.install "/" (@.binary int///)) - (@.install "%" (@.binary int//%)) - (@.install "=" (@.binary int//=)) - (@.install "<" (@.binary int//<)) - (@.install "and" (@.binary int//and)) - (@.install "or" (@.binary int//or)) - (@.install "xor" (@.binary int//xor)) - (@.install "shl" (@.binary int//shl)) - (@.install "shr" (@.binary int//shr)) - (@.install "ushr" (@.binary int//ushr)) - ))) - -(def: long-procs - @.Bundle - (<| (@.prefix "long") - (|> (dict.new text.hash) - (@.install "+" (@.binary long//+)) - (@.install "-" (@.binary long//-)) - (@.install "*" (@.binary long//*)) - (@.install "/" (@.binary long///)) - (@.install "%" (@.binary long//%)) - (@.install "=" (@.binary long//=)) - (@.install "<" (@.binary long//<)) - (@.install "and" (@.binary long//and)) - (@.install "or" (@.binary long//or)) - (@.install "xor" (@.binary long//xor)) - (@.install "shl" (@.binary long//shl)) - (@.install "shr" (@.binary long//shr)) - (@.install "ushr" (@.binary long//ushr)) - ))) - -(def: float-procs - @.Bundle - (<| (@.prefix "float") - (|> (dict.new text.hash) - (@.install "+" (@.binary float//+)) - (@.install "-" (@.binary float//-)) - (@.install "*" (@.binary float//*)) - (@.install "/" (@.binary float///)) - (@.install "%" (@.binary float//%)) - (@.install "=" (@.binary float//=)) - (@.install "<" (@.binary float//<)) - ))) - -(def: double-procs - @.Bundle - (<| (@.prefix "double") - (|> (dict.new text.hash) - (@.install "+" (@.binary double//+)) - (@.install "-" (@.binary double//-)) - (@.install "*" (@.binary double//*)) - (@.install "/" (@.binary double///)) - (@.install "%" (@.binary double//%)) - (@.install "=" (@.binary double//=)) - (@.install "<" (@.binary double//<)) - ))) - -(def: char-procs - @.Bundle - (<| (@.prefix "char") - (|> (dict.new text.hash) - (@.install "=" (@.binary char//=)) - (@.install "<" (@.binary char//<)) - ))) - -(def: (array//length arrayI) - @.Unary - (|>> arrayI - _.ARRAYLENGTH - _.I2L - (_.wrap #$.Long))) - -(def: (array//new proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) - (do macro.monad - [lengthI (translate lengthS) - #let [arrayJT ($t.array level (case class - "boolean" $t.boolean - "byte" $t.byte - "short" $t.short - "int" $t.int - "long" $t.long - "float" $t.float - "double" $t.double - "char" $t.char - _ ($t.class class (list))))]] - (wrap (|>> lengthI - (_.unwrap #$.Long) - _.L2I - (_.array arrayJT)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (array//read proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] idxS arrayS)) - (do macro.monad - [arrayI (translate arrayS) - idxI (translate idxS) - #let [loadI (case class - "boolean" (|>> _.BALOAD (_.wrap #$.Boolean)) - "byte" (|>> _.BALOAD (_.wrap #$.Byte)) - "short" (|>> _.SALOAD (_.wrap #$.Short)) - "int" (|>> _.IALOAD (_.wrap #$.Int)) - "long" (|>> _.LALOAD (_.wrap #$.Long)) - "float" (|>> _.FALOAD (_.wrap #$.Float)) - "double" (|>> _.DALOAD (_.wrap #$.Double)) - "char" (|>> _.CALOAD (_.wrap #$.Char)) - _ _.AALOAD)]] - (wrap (|>> arrayI - idxI - (_.unwrap #$.Long) - _.L2I - loadI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (array//write proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] idxS valueS arrayS)) - (do macro.monad - [arrayI (translate arrayS) - idxI (translate idxS) - valueI (translate valueS) - #let [storeI (case class - "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE) - "byte" (|>> (_.unwrap #$.Byte) _.BASTORE) - "short" (|>> (_.unwrap #$.Short) _.SASTORE) - "int" (|>> (_.unwrap #$.Int) _.IASTORE) - "long" (|>> (_.unwrap #$.Long) _.LASTORE) - "float" (|>> (_.unwrap #$.Float) _.FASTORE) - "double" (|>> (_.unwrap #$.Double) _.DASTORE) - "char" (|>> (_.unwrap #$.Char) _.CASTORE) - _ _.AASTORE)]] - (wrap (|>> arrayI - _.DUP - idxI - (_.unwrap #$.Long) - _.L2I - valueI - storeI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: array-procs - @.Bundle - (<| (@.prefix "array") - (|> (dict.new text.hash) - (@.install "length" (@.unary array//length)) - (@.install "new" array//new) - (@.install "read" array//read) - (@.install "write" array//write) - ))) - -(def: (object//null _) - @.Nullary - _.NULL) - -(def: (object//null? objectI) - @.Unary - (<| _.with-label (function (_ @then)) - _.with-label (function (_ @end)) - (|>> objectI - (_.IFNULL @then) - falseI - (_.GOTO @end) - (_.label @then) - trueI - (_.label @end)))) - -(def: (object//synchronized [monitorI exprI]) - @.Binary - (|>> monitorI - _.DUP - _.MONITORENTER - exprI - _.SWAP - _.MONITOREXIT)) - -(def: (object//throw exceptionI) - @.Unary - (|>> exceptionI - _.ATHROW)) - -(def: (object//class proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)])) - (do macro.monad - [] - (wrap (|>> (_.string class) - (_.INVOKESTATIC "java.lang.Class" "forName" - ($t.method (list ($t.class "java.lang.String" (list))) - (#.Some ($t.class "java.lang.Class" (list))) - (list)) - #0)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//instance? proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] objectS)) - (do macro.monad - [objectI (translate objectS)] - (wrap (|>> objectI - (_.INSTANCEOF class) - (_.wrap #$.Boolean)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (object//cast proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS)) - (do macro.monad - [valueI (translate valueS)] - (case [from to] - ## Wrap - (^template [<primitive> <object> <type>] - [<primitive> <object>] - (wrap (|>> valueI (_.wrap <type>))) - - [<object> <primitive>] - (wrap (|>> valueI (_.unwrap <type>)))) - (["boolean" "java.lang.Boolean" #$.Boolean] - ["byte" "java.lang.Byte" #$.Byte] - ["short" "java.lang.Short" #$.Short] - ["int" "java.lang.Integer" #$.Int] - ["long" "java.lang.Long" #$.Long] - ["float" "java.lang.Float" #$.Float] - ["double" "java.lang.Double" #$.Double] - ["char" "java.lang.Character" #$.Char]) - - _ - (wrap valueI))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: object-procs - @.Bundle - (<| (@.prefix "object") - (|> (dict.new text.hash) - (@.install "null" (@.nullary object//null)) - (@.install "null?" (@.unary object//null?)) - (@.install "synchronized" (@.binary object//synchronized)) - (@.install "throw" (@.unary object//throw)) - (@.install "class" object//class) - (@.install "instance?" object//instance?) - (@.install "cast" object//cast) - ))) - -(def: primitives - (Dict Text $.Primitive) - (|> (list ["boolean" #$.Boolean] - ["byte" #$.Byte] - ["short" #$.Short] - ["int" #$.Int] - ["long" #$.Long] - ["float" #$.Float] - ["double" #$.Double] - ["char" #$.Char]) - (dict.from-list text.hash))) - -(def: (static//get proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) - (do macro.monad - [] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive)) - (_.wrap primitive)))) - - #.None - (wrap (_.GETSTATIC class field ($t.class unboxed (list)))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (static//put proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) - (do macro.monad - [valueI (translate valueS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> valueI - (_.unwrap primitive) - (_.PUTSTATIC class field (#$.Primitive primitive)) - (_.string hostL.unit)))) - - #.None - (wrap (|>> valueI - (_.CHECKCAST class) - (_.PUTSTATIC class field ($t.class class (list))) - (_.string hostL.unit))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (virtual//get proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) - (do macro.monad - [objectI (translate objectS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.GETFIELD class field (#$.Primitive primitive)) - (_.wrap primitive)))) - - #.None - (wrap (|>> objectI - (_.CHECKCAST class) - (_.GETFIELD class field ($t.class unboxed (list))))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: (virtual//put proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) - (do macro.monad - [valueI (translate valueS) - objectI (translate objectS)] - (case (dict.get unboxed primitives) - (#.Some primitive) - (let [primitive (case unboxed - "boolean" #$.Boolean - "byte" #$.Byte - "short" #$.Short - "int" #$.Int - "long" #$.Long - "float" #$.Float - "double" #$.Double - "char" #$.Char - _ (undefined))] - (wrap (|>> objectI - (_.CHECKCAST class) - _.DUP - valueI - (_.unwrap primitive) - (_.PUTFIELD class field (#$.Primitive primitive))))) - - #.None - (wrap (|>> objectI - (_.CHECKCAST class) - _.DUP - valueI - (_.CHECKCAST unboxed) - (_.PUTFIELD class field ($t.class unboxed (list))))))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: base-type - (l.Lexer $.Type) - ($_ p.either - (p.after (l.this "boolean") (parser/wrap $t.boolean)) - (p.after (l.this "byte") (parser/wrap $t.byte)) - (p.after (l.this "short") (parser/wrap $t.short)) - (p.after (l.this "int") (parser/wrap $t.int)) - (p.after (l.this "long") (parser/wrap $t.long)) - (p.after (l.this "float") (parser/wrap $t.float)) - (p.after (l.this "double") (parser/wrap $t.double)) - (p.after (l.this "char") (parser/wrap $t.char)) - (parser/map (function (_ name) - ($t.class name (list))) - (l.many (l.none-of "["))) - )) - -(def: java-type - (l.Lexer $.Type) - (do p.monad - [raw base-type - nesting (p.some (l.this "[]"))] - (wrap ($t.array (list.size nesting) raw)))) - -(def: (translate-type argD) - (-> Text (Meta $.Type)) - (case (l.run argD java-type) - (#e.Error error) - (&.throw Invalid-Syntax-For-JVM-Type argD) - - (#e.Success type) - (macro/wrap type))) - -(def: (translate-arg translate argS) - (-> (-> ls.Synthesis (Meta $.Inst)) ls.Synthesis - (Meta [$.Type $.Inst])) - (case argS - (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))]) - (do macro.monad - [argT (translate-type argD) - argI (translate argS)] - (wrap [argT argI])) - - _ - (&.throw Invalid-Syntax-For-Argument-Generation ""))) - -(def: (method-return-type description) - (-> Text (Meta (Maybe $.Type))) - (case description - "void" - (macro/wrap #.None) - - _ - (macro/map (|>> #.Some) (translate-type description)))) - -(def: (invoke//static proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] [_ (#.Text method)] - [_ (#.Text unboxed)] argsS)) - (do macro.monad - [argsTI (monad.map @ (translate-arg translate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> (_.fuse (list/map product.right argsTI)) - (_.INVOKESTATIC class method - ($t.method (list/map product.left argsTI) returnT (list)) - #0)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(template [<name> <invoke> <interface?>] - [(def: (<name> proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] [_ (#.Text method)] - [_ (#.Text unboxed)] objectS argsS)) - (do macro.monad - [objectI (translate objectS) - argsTI (monad.map @ (translate-arg translate) argsS) - returnT (method-return-type unboxed)] - (wrap (|>> objectI - (_.CHECKCAST class) - (_.fuse (list/map product.right argsTI)) - (<invoke> class method - ($t.method (list/map product.left argsTI) returnT (list)) - <interface?>)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))] - - [invoke//virtual _.INVOKEVIRTUAL #0] - [invoke//special _.INVOKESPECIAL #0] - [invoke//interface _.INVOKEINTERFACE #1] - ) - -(def: (invoke//constructor proc translate inputs) - (-> Text @.Proc) - (case inputs - (^ (list& [_ (#.Text class)] argsS)) - (do macro.monad - [argsTI (monad.map @ (translate-arg translate) argsS)] - (wrap (|>> (_.NEW class) - _.DUP - (_.fuse (list/map product.right argsTI)) - (_.INVOKESPECIAL class "<init>" - ($t.method (list/map product.left argsTI) #.None (list)) - #0)))) - - _ - (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -(def: member-procs - @.Bundle - (<| (@.prefix "member") - (|> (dict.new text.hash) - (dict.merge (<| (@.prefix "static") - (|> (dict.new text.hash) - (@.install "get" static//get) - (@.install "put" static//put)))) - (dict.merge (<| (@.prefix "virtual") - (|> (dict.new text.hash) - (@.install "get" virtual//get) - (@.install "put" virtual//put)))) - (dict.merge (<| (@.prefix "invoke") - (|> (dict.new text.hash) - (@.install "static" invoke//static) - (@.install "virtual" invoke//virtual) - (@.install "special" invoke//special) - (@.install "interface" invoke//interface) - (@.install "constructor" invoke//constructor)))) - ))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "jvm") - (|> conversion-procs - (dict.merge int-procs) - (dict.merge long-procs) - (dict.merge float-procs) - (dict.merge double-procs) - (dict.merge char-procs) - (dict.merge array-procs) - (dict.merge object-procs) - (dict.merge member-procs) - ))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux new file mode 100644 index 000000000..45e025d0b --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -0,0 +1,753 @@ +(.module: + [lux (#- int char) + [abstract + ["." monad (#+ do)]] + [control + ["p" parser ("#@." monad)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error] + ["." text + format + ["l" lexer]] + [collection + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] + [tool + [compiler + ["." synthesis (#+ Synthesis %synthesis)] + ["." phase ("#@." monad) + [generation + [extension (#+ Nullary Unary Binary + nullary unary binary)]] + ["." extension + ["." bundle]]]]] + [host (#+ import:)]] + [luxc + [lang + [host + ["$" jvm (#+ Primitive Label Inst Method Handler Bundle Operation) + ["_t" type] + ["_" inst]]]]]) + +(template [<name>] + [(exception: #export (<name> {message Text}) + message)] + + [invalid-syntax-for-jvm-type] + [invalid-syntax-for-argument-generation] + ) + +(template [<name> <inst>] + [(def: <name> + Inst + <inst>)] + + [L2S (|>> _.L2I _.I2S)] + [L2B (|>> _.L2I _.I2B)] + [L2C (|>> _.L2I _.I2C)] + ) + +(template [<name> <unwrap> <conversion> <wrap>] + [(def: (<name> inputI) + (Unary Inst) + (if (is? _.NOP <conversion>) + (|>> inputI + (_.unwrap <unwrap>) + (_.wrap <wrap>)) + (|>> inputI + (_.unwrap <unwrap>) + <conversion> + (_.wrap <wrap>))))] + + [convert::double-to-float #$.Double _.D2F #$.Float] + [convert::double-to-int #$.Double _.D2I #$.Int] + [convert::double-to-long #$.Double _.D2L #$.Long] + [convert::float-to-double #$.Float _.F2D #$.Double] + [convert::float-to-int #$.Float _.F2I #$.Int] + [convert::float-to-long #$.Float _.F2L #$.Long] + [convert::int-to-byte #$.Int _.I2B #$.Byte] + [convert::int-to-char #$.Int _.I2C #$.Char] + [convert::int-to-double #$.Int _.I2D #$.Double] + [convert::int-to-float #$.Int _.I2F #$.Float] + [convert::int-to-long #$.Int _.I2L #$.Long] + [convert::int-to-short #$.Int _.I2S #$.Short] + [convert::long-to-double #$.Long _.L2D #$.Double] + [convert::long-to-float #$.Long _.L2F #$.Float] + [convert::long-to-int #$.Long _.L2I #$.Int] + [convert::long-to-short #$.Long L2S #$.Short] + [convert::long-to-byte #$.Long L2B #$.Byte] + [convert::long-to-char #$.Long L2C #$.Char] + [convert::char-to-byte #$.Char _.I2B #$.Byte] + [convert::char-to-short #$.Char _.I2S #$.Short] + [convert::char-to-int #$.Char _.NOP #$.Int] + [convert::char-to-long #$.Char _.I2L #$.Long] + [convert::byte-to-long #$.Byte _.I2L #$.Long] + [convert::short-to-long #$.Short _.I2L #$.Long] + ) + +(def: conversion + Bundle + (<| (bundle.prefix "convert") + (|> (: Bundle bundle.empty) + (bundle.install "double-to-float" (unary convert::double-to-float)) + (bundle.install "double-to-int" (unary convert::double-to-int)) + (bundle.install "double-to-long" (unary convert::double-to-long)) + (bundle.install "float-to-double" (unary convert::float-to-double)) + (bundle.install "float-to-int" (unary convert::float-to-int)) + (bundle.install "float-to-long" (unary convert::float-to-long)) + (bundle.install "int-to-byte" (unary convert::int-to-byte)) + (bundle.install "int-to-char" (unary convert::int-to-char)) + (bundle.install "int-to-double" (unary convert::int-to-double)) + (bundle.install "int-to-float" (unary convert::int-to-float)) + (bundle.install "int-to-long" (unary convert::int-to-long)) + (bundle.install "int-to-short" (unary convert::int-to-short)) + (bundle.install "long-to-double" (unary convert::long-to-double)) + (bundle.install "long-to-float" (unary convert::long-to-float)) + (bundle.install "long-to-int" (unary convert::long-to-int)) + (bundle.install "long-to-short" (unary convert::long-to-short)) + (bundle.install "long-to-byte" (unary convert::long-to-byte)) + (bundle.install "long-to-char" (unary convert::long-to-char)) + (bundle.install "char-to-byte" (unary convert::char-to-byte)) + (bundle.install "char-to-short" (unary convert::char-to-short)) + (bundle.install "char-to-int" (unary convert::char-to-int)) + (bundle.install "char-to-long" (unary convert::char-to-long)) + (bundle.install "byte-to-long" (unary convert::byte-to-long)) + (bundle.install "short-to-long" (unary convert::short-to-long)) + ))) + +(template [<name> <op> <unwrapX> <unwrapY> <wrap>] + [(def: (<name> [xI yI]) + (Binary Inst) + (|>> xI (_.unwrap <unwrapX>) + yI (_.unwrap <unwrapY>) + <op> (_.wrap <wrap>)))] + + [int::+ _.IADD #$.Int #$.Int #$.Int] + [int::- _.ISUB #$.Int #$.Int #$.Int] + [int::* _.IMUL #$.Int #$.Int #$.Int] + [int::/ _.IDIV #$.Int #$.Int #$.Int] + [int::% _.IREM #$.Int #$.Int #$.Int] + [int::and _.IAND #$.Int #$.Int #$.Int] + [int::or _.IOR #$.Int #$.Int #$.Int] + [int::xor _.IXOR #$.Int #$.Int #$.Int] + [int::shl _.ISHL #$.Int #$.Int #$.Int] + [int::shr _.ISHR #$.Int #$.Int #$.Int] + [int::ushr _.IUSHR #$.Int #$.Int #$.Int] + + [long::+ _.LADD #$.Long #$.Long #$.Long] + [long::- _.LSUB #$.Long #$.Long #$.Long] + [long::* _.LMUL #$.Long #$.Long #$.Long] + [long::/ _.LDIV #$.Long #$.Long #$.Long] + [long::% _.LREM #$.Long #$.Long #$.Long] + [long::and _.LAND #$.Long #$.Long #$.Long] + [long::or _.LOR #$.Long #$.Long #$.Long] + [long::xor _.LXOR #$.Long #$.Long #$.Long] + [long::shl _.LSHL #$.Long #$.Int #$.Long] + [long::shr _.LSHR #$.Long #$.Int #$.Long] + [long::ushr _.LUSHR #$.Long #$.Int #$.Long] + + [float::+ _.FADD #$.Float #$.Float #$.Float] + [float::- _.FSUB #$.Float #$.Float #$.Float] + [float::* _.FMUL #$.Float #$.Float #$.Float] + [float::/ _.FDIV #$.Float #$.Float #$.Float] + [float::% _.FREM #$.Float #$.Float #$.Float] + + [double::+ _.DADD #$.Double #$.Double #$.Double] + [double::- _.DSUB #$.Double #$.Double #$.Double] + [double::* _.DMUL #$.Double #$.Double #$.Double] + [double::/ _.DDIV #$.Double #$.Double #$.Double] + [double::% _.DREM #$.Double #$.Double #$.Double] + ) + +(def: boolean-class (_t.class "java.lang.Boolean" (list))) +(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class)) +(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class)) + +(template [<name> <op> <unwrap>] + [(def: (<name> [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI (_.unwrap <unwrap>) + yI (_.unwrap <unwrap>) + (<op> @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [int::= _.IF_ICMPEQ #$.Int] + [int::< _.IF_ICMPLT #$.Int] + + [char::= _.IF_ICMPEQ #$.Char] + [char::< _.IF_ICMPLT #$.Char] + ) + +(template [<name> <op> <reference> <unwrap>] + [(def: (<name> [xI yI]) + (Binary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> xI (_.unwrap <unwrap>) + yI (_.unwrap <unwrap>) + <op> + (_.int <reference>) + (_.IF_ICMPEQ @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end))))] + + [long::= _.LCMP +0 #$.Long] + [long::< _.LCMP -1 #$.Long] + + [float::= _.FCMPG +0 #$.Float] + [float::< _.FCMPG -1 #$.Float] + + [double::= _.DCMPG +0 #$.Double] + [double::< _.DCMPG -1 #$.Double] + ) + +(def: int + Bundle + (<| (bundle.prefix "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: long + Bundle + (<| (bundle.prefix "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: float + Bundle + (<| (bundle.prefix "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: double + Bundle + (<| (bundle.prefix "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: char + Bundle + (<| (bundle.prefix "char") + (|> (: Bundle bundle.empty) + (bundle.install "=" (binary char::=)) + (bundle.install "<" (binary char::<)) + ))) + +(def: (array::length arrayD arrayI) + (Binary Inst) + (|>> arrayI + (_.CHECKCAST arrayD) + _.ARRAYLENGTH + _.I2L + (_.wrap #$.Long))) + +(def: (array::new proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.i64 level) + (synthesis.text class) + lengthS)) + (do phase.monad + [lengthI (generate lengthS) + #let [arrayJT (_t.array (.nat level) + (case class + "boolean" _t.boolean + "byte" _t.byte + "short" _t.short + "int" _t.int + "long" _t.long + "float" _t.float + "double" _t.double + "char" _t.char + _ (_t.class class (list))))]] + (wrap (|>> lengthI + (_.unwrap #$.Long) + _.L2I + (_.array arrayJT)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (array::read proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + idxS + arrayS)) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS) + #let [loadI (case class + "boolean" (|>> _.BALOAD (_.wrap #$.Boolean)) + "byte" (|>> _.BALOAD (_.wrap #$.Byte)) + "short" (|>> _.SALOAD (_.wrap #$.Short)) + "int" (|>> _.IALOAD (_.wrap #$.Int)) + "long" (|>> _.LALOAD (_.wrap #$.Long)) + "float" (|>> _.FALOAD (_.wrap #$.Float)) + "double" (|>> _.DALOAD (_.wrap #$.Double)) + "char" (|>> _.CALOAD (_.wrap #$.Char)) + _ _.AALOAD)]] + (wrap (|>> arrayI + idxI + (_.unwrap #$.Long) + _.L2I + loadI))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (array::write proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + idxS + valueS + arrayS)) + (do phase.monad + [arrayI (generate arrayS) + idxI (generate idxS) + valueI (generate valueS) + #let [storeI (case class + "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE) + "byte" (|>> (_.unwrap #$.Byte) _.BASTORE) + "short" (|>> (_.unwrap #$.Short) _.SASTORE) + "int" (|>> (_.unwrap #$.Int) _.IASTORE) + "long" (|>> (_.unwrap #$.Long) _.LASTORE) + "float" (|>> (_.unwrap #$.Float) _.FASTORE) + "double" (|>> (_.unwrap #$.Double) _.DASTORE) + "char" (|>> (_.unwrap #$.Char) _.CASTORE) + _ _.AASTORE)]] + (wrap (|>> arrayI + _.DUP + idxI + (_.unwrap #$.Long) + _.L2I + valueI + storeI))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> (: Bundle bundle.empty) + (bundle.install "length" (unary array::length)) + (bundle.install "new" array::new) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + ))) + +(def: (object::null _) + (Nullary Inst) + _.NULL) + +(def: (object::null? objectI) + (Unary Inst) + (<| _.with-label (function (_ @then)) + _.with-label (function (_ @end)) + (|>> objectI + (_.IFNULL @then) + falseI + (_.GOTO @end) + (_.label @then) + trueI + (_.label @end)))) + +(def: (object::synchronized [monitorI exprI]) + (Binary Inst) + (|>> monitorI + _.DUP + _.MONITORENTER + exprI + _.SWAP + _.MONITOREXIT)) + +(def: (object::throw exceptionI) + (Unary Inst) + (|>> exceptionI + _.ATHROW)) + +(def: (object::class proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class))) + (do phase.monad + [] + (wrap (|>> (_.string class) + (_.INVOKESTATIC "java.lang.Class" "forName" + (_t.method (list (_t.class "java.lang.String" (list))) + (#.Some (_t.class "java.lang.Class" (list))) + (list)) + false)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (object::instance? proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) objectS)) + (do phase.monad + [objectI (generate objectS)] + (wrap (|>> objectI + (_.INSTANCEOF class) + (_.wrap #$.Boolean)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (object::cast proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text from) (synthesis.text to) valueS)) + (do phase.monad + [valueI (generate valueS)] + (case [from to] + ## Wrap + (^template [<primitive> <object> <type>] + [<primitive> <object>] + (wrap (|>> valueI (_.wrap <type>))) + + [<object> <primitive>] + (wrap (|>> valueI (_.unwrap <type>)))) + (["boolean" "java.lang.Boolean" #$.Boolean] + ["byte" "java.lang.Byte" #$.Byte] + ["short" "java.lang.Short" #$.Short] + ["int" "java.lang.Integer" #$.Int] + ["long" "java.lang.Long" #$.Long] + ["float" "java.lang.Float" #$.Float] + ["double" "java.lang.Double" #$.Double] + ["char" "java.lang.Character" #$.Char]) + + _ + (wrap valueI))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: 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 Primitive) + (|> (list ["boolean" #$.Boolean] + ["byte" #$.Byte] + ["short" #$.Short] + ["int" #$.Int] + ["long" #$.Long] + ["float" #$.Float] + ["double" #$.Double] + ["char" #$.Char]) + (dictionary.from-list text.hash))) + +(def: (static::get proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed))) + (do phase.monad + [] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive)) + (_.wrap primitive))) + + #.None + (wrap (_.GETSTATIC class field (_t.class unboxed (list)))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (static::put proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed) + valueS)) + (do phase.monad + [valueI (generate valueS)] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> valueI + (_.unwrap primitive) + (_.PUTSTATIC class field (#$.Primitive primitive)) + (_.string synthesis.unit))) + + #.None + (wrap (|>> valueI + (_.CHECKCAST class) + (_.PUTSTATIC class field (_t.class class (list))) + (_.string synthesis.unit))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (virtual::get proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed) + objectS)) + (do phase.monad + [objectI (generate objectS)] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> objectI + (_.CHECKCAST class) + (_.GETFIELD class field (#$.Primitive primitive)) + (_.wrap primitive))) + + #.None + (wrap (|>> objectI + (_.CHECKCAST class) + (_.GETFIELD class field (_t.class unboxed (list))))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: (virtual::put proc generate inputs) + Handler + (case inputs + (^ (list (synthesis.text class) + (synthesis.text field) + (synthesis.text unboxed) + valueS + objectS)) + (do phase.monad + [valueI (generate valueS) + objectI (generate objectS)] + (case (dictionary.get unboxed primitives) + (#.Some primitive) + (wrap (|>> objectI + (_.CHECKCAST class) + _.DUP + valueI + (_.unwrap primitive) + (_.PUTFIELD class field (#$.Primitive primitive)))) + + #.None + (wrap (|>> objectI + (_.CHECKCAST class) + _.DUP + valueI + (_.CHECKCAST unboxed) + (_.PUTFIELD class field (_t.class unboxed (list))))))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: base-type + (l.Lexer $.Type) + ($_ p.either + (p.after (l.this "boolean") (p@wrap _t.boolean)) + (p.after (l.this "byte") (p@wrap _t.byte)) + (p.after (l.this "short") (p@wrap _t.short)) + (p.after (l.this "int") (p@wrap _t.int)) + (p.after (l.this "long") (p@wrap _t.long)) + (p.after (l.this "float") (p@wrap _t.float)) + (p.after (l.this "double") (p@wrap _t.double)) + (p.after (l.this "char") (p@wrap _t.char)) + (p@map (function (_ name) + (_t.class name (list))) + (l.many (l.none-of "["))) + )) + +(def: java-type + (l.Lexer $.Type) + (do p.monad + [raw base-type + nesting (p.some (l.this "[]"))] + (wrap (_t.array (list.size nesting) raw)))) + +(def: (generate-type argD) + (-> Text (Operation $.Type)) + (case (l.run argD java-type) + (#error.Failure error) + (phase.throw invalid-syntax-for-jvm-type argD) + + (#error.Success type) + (phase@wrap type))) + +(def: (generate-arg generate argS) + (-> (-> Synthesis (Operation Inst)) Synthesis + (Operation [$.Type Inst])) + (case argS + (^ (synthesis.tuple (list (synthesis.text argD) argS))) + (do phase.monad + [argT (generate-type argD) + argI (generate argS)] + (wrap [argT argI])) + + _ + (phase.throw invalid-syntax-for-argument-generation ""))) + +(def: (method-return-type description) + (-> Text (Operation (Maybe $.Type))) + (case description + "void" + (phase@wrap #.None) + + _ + (phase@map (|>> #.Some) (generate-type description)))) + +(def: (invoke::static proc generate inputs) + Handler + (case inputs + (^ (list& (synthesis.text class) + (synthesis.text method) + (synthesis.text unboxed) + argsS)) + (do phase.monad + [argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> (_.fuse (list@map product.right argsTI)) + (_.INVOKESTATIC class method + (_t.method (list@map product.left argsTI) returnT (list)) + false)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(template [<name> <invoke> <interface?>] + [(def: (<name> proc generate inputs) + Handler + (case inputs + (^ (list& (synthesis.text class) + (synthesis.text method) + (synthesis.text unboxed) + objectS + argsS)) + (do phase.monad + [objectI (generate objectS) + argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> objectI + (_.CHECKCAST class) + (_.fuse (list@map product.right argsTI)) + (<invoke> class method + (_t.method (list@map product.left argsTI) returnT (list)) + <interface?>)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs])))] + + [invoke::virtual _.INVOKEVIRTUAL false] + [invoke::special _.INVOKESPECIAL false] + [invoke::interface _.INVOKEINTERFACE true] + ) + +(def: (invoke::constructor proc generate inputs) + Handler + (case inputs + (^ (list& (synthesis.text class) argsS)) + (do phase.monad + [argsTI (monad.map @ (generate-arg generate) argsS)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse (list@map product.right argsTI)) + (_.INVOKESPECIAL class "<init>" + (_t.method (list@map product.left argsTI) #.None (list)) + false)))) + + _ + (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) + +(def: member + Bundle + (<| (bundle.prefix "member") + (|> (: Bundle bundle.empty) + (dictionary.merge (<| (bundle.prefix "static") + (|> (: Bundle bundle.empty) + (bundle.install "get" static::get) + (bundle.install "put" static::put)))) + (dictionary.merge (<| (bundle.prefix "virtual") + (|> (: Bundle bundle.empty) + (bundle.install "get" virtual::get) + (bundle.install "put" virtual::put)))) + (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: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> ..conversion + (dictionary.merge ..int) + (dictionary.merge ..long) + (dictionary.merge ..float) + (dictionary.merge ..double) + (dictionary.merge ..char) + (dictionary.merge ..array) + (dictionary.merge ..object) + (dictionary.merge ..member) + ))) |