aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux761
1 files changed, 0 insertions, 761 deletions
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)
- )))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-26 23:19:21 +0000