aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/inst.lux125
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux65
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux84
3 files changed, 172 insertions, 102 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
index 33aa290df..040f6f04a 100644
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -8,6 +8,7 @@
["p" parser
["s" code]]]
[data
+ ["." product]
["." maybe]
["." error]
[text
@@ -16,6 +17,7 @@
["." list ("#@." functor)]]]
[macro
["." code]
+ ["." template]
[syntax (#+ syntax:)]]
[target
[jvm
@@ -34,7 +36,7 @@
(list@map (function (_ code) (` ((~' #static) (~ (code.local-identifier code)) (~' int)))))
wrap))
-(`` (import: org/objectweb/asm/Opcodes
+(`` (import: #long org/objectweb/asm/Opcodes
(#static NOP int)
## Conversion
@@ -103,42 +105,43 @@
(~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN))
))
-(import: org/objectweb/asm/Label
+(import: #long org/objectweb/asm/Label
(new []))
-(import: org/objectweb/asm/MethodVisitor
+(import: #long org/objectweb/asm/MethodVisitor
(visitCode [] void)
(visitMaxs [int int] void)
(visitEnd [] void)
(visitInsn [int] void)
- (visitLdcInsn [Object] void)
- (visitFieldInsn [int String String String] void)
- (visitTypeInsn [int String] void)
+ (visitLdcInsn [java/lang/Object] void)
+ (visitFieldInsn [int java/lang/String java/lang/String java/lang/String] void)
+ (visitTypeInsn [int java/lang/String] void)
(visitVarInsn [int int] void)
(visitIntInsn [int int] void)
- (visitMethodInsn [int String String String boolean] void)
- (visitLabel [Label] void)
- (visitJumpInsn [int Label] void)
- (visitTryCatchBlock [Label Label Label String] void)
- (visitTableSwitchInsn [int int Label (Array Label)] void)
+ (visitMethodInsn [int java/lang/String java/lang/String java/lang/String boolean] void)
+ (visitLabel [org/objectweb/asm/Label] void)
+ (visitJumpInsn [int org/objectweb/asm/Label] void)
+ (visitTryCatchBlock [org/objectweb/asm/Label org/objectweb/asm/Label org/objectweb/asm/Label java/lang/String] void)
+ (visitLookupSwitchInsn [org/objectweb/asm/Label (Array int) (Array org/objectweb/asm/Label)] void)
+ (visitTableSwitchInsn [int int org/objectweb/asm/Label (Array org/objectweb/asm/Label)] void)
)
## [Insts]
(def: #export make-label
- (All [s] (Operation s Label))
+ (All [s] (Operation s org/objectweb/asm/Label))
(function (_ state)
- (#error.Success [state (Label::new)])))
+ (#error.Success [state (org/objectweb/asm/Label::new)])))
(def: #export (with-label action)
- (-> (-> Label Inst) Inst)
- (action (Label::new)))
+ (All [a] (-> (-> org/objectweb/asm/Label a) a))
+ (action (org/objectweb/asm/Label::new)))
(template [<name> <type> <prepare>]
[(def: #export (<name> value)
(-> <type> Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitLdcInsn (<prepare> value)))))]
+ (org/objectweb/asm/MethodVisitor::visitLdcInsn (<prepare> value)))))]
[boolean Bit function.identity]
[int Int host.long-to-int]
@@ -148,21 +151,21 @@
[string Text function.identity]
)
-(syntax: (prefix {base s.local-identifier})
- (wrap (list (` ((~ (code.local-identifier (format "Opcodes::" base))))))))
+(template: (prefix short)
+ (`` ((~~ (template.identifier ["org/objectweb/asm/Opcodes::" short])))))
(def: #export NULL
Inst
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitInsn (prefix ACONST_NULL)))))
+ (org/objectweb/asm/MethodVisitor::visitInsn (prefix ACONST_NULL)))))
(template [<name>]
[(def: #export <name>
Inst
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitInsn (prefix <name>)))))]
+ (org/objectweb/asm/MethodVisitor::visitInsn (prefix <name>)))))]
[NOP]
@@ -223,7 +226,7 @@
(-> Nat Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitVarInsn (prefix <name>) (.int register)))))]
+ (org/objectweb/asm/MethodVisitor::visitVarInsn (prefix <name>) (.int register)))))]
[ILOAD] [LLOAD] [DLOAD] [ALOAD]
[ISTORE] [LSTORE] [ASTORE]
@@ -234,13 +237,13 @@
(-> Text Text Type Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))]
+ (org/objectweb/asm/MethodVisitor::visitFieldInsn (<inst>) (type.binary-name class) field (type.descriptor type)))))]
- [GETSTATIC Opcodes::GETSTATIC]
- [PUTSTATIC Opcodes::PUTSTATIC]
+ [GETSTATIC org/objectweb/asm/Opcodes::GETSTATIC]
+ [PUTSTATIC org/objectweb/asm/Opcodes::PUTSTATIC]
- [PUTFIELD Opcodes::PUTFIELD]
- [GETFIELD Opcodes::GETFIELD]
+ [PUTFIELD org/objectweb/asm/Opcodes::PUTFIELD]
+ [GETFIELD org/objectweb/asm/Opcodes::GETFIELD]
)
(template [<name> <inst>]
@@ -248,40 +251,40 @@
(-> Text Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitTypeInsn (<inst>) (type.binary-name class)))))]
+ (org/objectweb/asm/MethodVisitor::visitTypeInsn (<inst>) (type.binary-name class)))))]
- [CHECKCAST Opcodes::CHECKCAST]
- [NEW Opcodes::NEW]
- [INSTANCEOF Opcodes::INSTANCEOF]
- [ANEWARRAY Opcodes::ANEWARRAY]
+ [CHECKCAST org/objectweb/asm/Opcodes::CHECKCAST]
+ [NEW org/objectweb/asm/Opcodes::NEW]
+ [INSTANCEOF org/objectweb/asm/Opcodes::INSTANCEOF]
+ [ANEWARRAY org/objectweb/asm/Opcodes::ANEWARRAY]
)
(def: #export (NEWARRAY type)
(-> Primitive Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitIntInsn (Opcodes::NEWARRAY)
- (case type
- #type.Boolean (Opcodes::T_BOOLEAN)
- #type.Byte (Opcodes::T_BYTE)
- #type.Short (Opcodes::T_SHORT)
- #type.Int (Opcodes::T_INT)
- #type.Long (Opcodes::T_LONG)
- #type.Float (Opcodes::T_FLOAT)
- #type.Double (Opcodes::T_DOUBLE)
- #type.Char (Opcodes::T_CHAR))))))
+ (org/objectweb/asm/MethodVisitor::visitIntInsn (org/objectweb/asm/Opcodes::NEWARRAY)
+ (case type
+ #type.Boolean (org/objectweb/asm/Opcodes::T_BOOLEAN)
+ #type.Byte (org/objectweb/asm/Opcodes::T_BYTE)
+ #type.Short (org/objectweb/asm/Opcodes::T_SHORT)
+ #type.Int (org/objectweb/asm/Opcodes::T_INT)
+ #type.Long (org/objectweb/asm/Opcodes::T_LONG)
+ #type.Float (org/objectweb/asm/Opcodes::T_FLOAT)
+ #type.Double (org/objectweb/asm/Opcodes::T_DOUBLE)
+ #type.Char (org/objectweb/asm/Opcodes::T_CHAR))))))
(template [<name> <inst>]
[(def: #export (<name> class method-name method-signature interface?)
(-> Text Text Method Bit Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))]
+ (org/objectweb/asm/MethodVisitor::visitMethodInsn (<inst>) (type.binary-name class) method-name (type.method-descriptor method-signature) interface?))))]
- [INVOKESTATIC Opcodes::INVOKESTATIC]
- [INVOKEVIRTUAL Opcodes::INVOKEVIRTUAL]
- [INVOKESPECIAL Opcodes::INVOKESPECIAL]
- [INVOKEINTERFACE Opcodes::INVOKEINTERFACE]
+ [INVOKESTATIC org/objectweb/asm/Opcodes::INVOKESTATIC]
+ [INVOKEVIRTUAL org/objectweb/asm/Opcodes::INVOKEVIRTUAL]
+ [INVOKESPECIAL org/objectweb/asm/Opcodes::INVOKESPECIAL]
+ [INVOKEINTERFACE org/objectweb/asm/Opcodes::INVOKEINTERFACE]
)
(template [<name>]
@@ -289,7 +292,7 @@
(-> //.Label Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitJumpInsn (prefix <name>) @where))))]
+ (org/objectweb/asm/MethodVisitor::visitJumpInsn (prefix <name>) @where))))]
[IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT]
[IF_ICMPNE] [IF_ICMPGE] [IF_ICMPLE]
@@ -298,11 +301,31 @@
[GOTO]
)
+(def: #export (LOOKUPSWITCH default keys+labels)
+ (-> //.Label (List [Int //.Label]) Inst)
+ (function (_ visitor)
+ (let [keys+labels (list.sort (function (_ left right)
+ (i/< (product.left left) (product.left right)))
+ keys+labels)
+ array-size (list.size keys+labels)
+ keys-array (host.array int array-size)
+ labels-array (host.array org/objectweb/asm/Label array-size)
+ _ (loop [idx 0]
+ (if (n/< array-size idx)
+ (let [[key label] (maybe.assume (list.nth idx keys+labels))]
+ (exec
+ (host.array-write idx (host.long-to-int key) keys-array)
+ (host.array-write idx label labels-array)
+ (recur (inc idx))))
+ []))]
+ (do-to visitor
+ (org/objectweb/asm/MethodVisitor::visitLookupSwitchInsn default keys-array labels-array)))))
+
(def: #export (TABLESWITCH min max default labels)
(-> Int Int //.Label (List //.Label) Inst)
(function (_ visitor)
(let [num-labels (list.size labels)
- labels-array (host.array Label num-labels)
+ labels-array (host.array org/objectweb/asm/Label num-labels)
_ (loop [idx 0]
(if (n/< num-labels idx)
(exec (host.array-write idx
@@ -311,19 +334,19 @@
(recur (inc idx)))
[]))]
(do-to visitor
- (MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
+ (org/objectweb/asm/MethodVisitor::visitTableSwitchInsn min max default labels-array)))))
(def: #export (try @from @to @handler exception)
(-> //.Label //.Label //.Label Text Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitTryCatchBlock @from @to @handler (type.binary-name exception)))))
+ (org/objectweb/asm/MethodVisitor::visitTryCatchBlock @from @to @handler (type.binary-name exception)))))
(def: #export (label @label)
(-> //.Label Inst)
(function (_ visitor)
(do-to visitor
- (MethodVisitor::visitLabel @label))))
+ (org/objectweb/asm/MethodVisitor::visitLabel @label))))
(def: #export (array type)
(-> Type Inst)
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
index ea67a0d4a..34462d9ba 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
@@ -3,19 +3,23 @@
[abstract
["." monad (#+ do)]]
[control
- ["p" parser]
+ ["<>" parser
+ ["<s>" synthesis (#+ Parser)]]
["ex" exception (#+ exception:)]]
[data
+ ["." product]
+ ["." error]
["." text
format]
[collection
+ ["." list ("#@." monad)]
["." dictionary]]]
[target
[jvm
["_t" type (#+ Type Method)]]]
[tool
[compiler
- ["." synthesis (#+ Synthesis)]
+ ["." synthesis (#+ Synthesis %synthesis)]
["." phase
[generation
[extension (#+ Nullary Unary Binary Trinary Variadic
@@ -26,11 +30,24 @@
[luxc
[lang
[host
- ["$" jvm (#+ Label Inst Bundle)
+ ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
["_" inst]]]]]
["." ///
["." runtime]])
+(def: #export (custom [parser handler])
+ (All [s]
+ (-> [(Parser s)
+ (-> Text Phase s (Operation Inst))]
+ Handler))
+ (function (_ extension-name phase input)
+ (case (<s>.run input parser)
+ (#error.Success input')
+ (handler extension-name phase input')
+
+ (#error.Failure error)
+ (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
+
(import: java/lang/Double
(#static MIN_VALUE Double)
(#static MAX_VALUE Double))
@@ -58,6 +75,47 @@
(def: unitI Inst (_.string synthesis.unit))
+## TODO: Get rid of this ASAP
+(def: lux::syntax-char-case!
+ (..custom [($_ <>.and
+ <s>.any
+ <s>.any
+ (<>.some (<s>.tuple ($_ <>.and
+ (<s>.tuple (<>.many <s>.i64))
+ <s>.any))))
+ (function (_ extension-name phase [input else conditionals])
+ (<| _.with-label (function (_ @end))
+ _.with-label (function (_ @else))
+ (do phase.monad
+ [inputG (phase input)
+ elseG (phase else)
+ conditionalsG+ (: (Operation (List [(List [Int Label])
+ Inst]))
+ (monad.map @ (function (_ [chars branch])
+ (do @
+ [branchG (phase branch)]
+ (wrap (<| _.with-label (function (_ @branch))
+ [(list@map (function (_ char)
+ [(.int char) @branch])
+ chars)
+ (|>> (_.label @branch)
+ branchG
+ (_.GOTO @end))]))))
+ conditionals))
+ #let [table (|> conditionalsG+
+ (list@map product.left)
+ list@join)
+ conditionalsG (|> conditionalsG+
+ (list@map product.right)
+ _.fuse)]]
+ (wrap (|>> inputG (_.unwrap #_t.Long) _.L2I
+ (_.LOOKUPSWITCH @else table)
+ conditionalsG
+ (_.label @else)
+ elseG
+ (_.label @end)
+ )))))]))
+
(def: (lux::is [referenceI sampleI])
(Binary Inst)
(|>> referenceI
@@ -251,6 +309,7 @@
(def: bundle::lux
Bundle
(|> (: Bundle bundle.empty)
+ (bundle.install "syntax char case!" lux::syntax-char-case!)
(bundle.install "is" (binary lux::is))
(bundle.install "try" (unary lux::try))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index e57101660..83cbd017b 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -6,7 +6,7 @@
["." exception (#+ exception:)]
["<>" parser ("#@." monad)
["<t>" text]
- ["<s>" synthesis]]]
+ ["<s>" synthesis (#+ Parser)]]]
[data
["." product]
["." maybe]
@@ -46,25 +46,14 @@
["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase)
["_" inst]
["_." def]]]]]
- ["." /// #_
- ["#." reference]
- ["#." function]])
+ ["." // #_
+ [common (#+ custom)]
+ ["/#" // #_
+ ["#." reference]
+ ["#." function]]])
(exception: #export invalid-syntax-for-argument-generation)
-(def: (custom [parser handler])
- (All [s]
- (-> [(<s>.Parser s)
- (-> Text Phase s (Operation Inst))]
- Handler))
- (function (_ extension-name phase input)
- (case (<s>.run input parser)
- (#error.Success input')
- (handler extension-name phase input')
-
- (#error.Failure error)
- (phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
-
(template [<name> <inst>]
[(def: <name>
Inst
@@ -322,13 +311,14 @@
(def: (primitive-array-length-handler jvm-primitive)
(-> Type Handler)
- (..custom [<s>.any
- (function (_ extension-name generate arrayS)
- (do phase.monad
- [arrayI (generate arrayS)]
- (wrap (|>> arrayI
- (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive)))
- _.ARRAYLENGTH))))]))
+ (..custom
+ [<s>.any
+ (function (_ extension-name generate arrayS)
+ (do phase.monad
+ [arrayI (generate arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive)))
+ _.ARRAYLENGTH))))]))
(def: (array::length::object extension-name generate inputs)
Handler
@@ -543,18 +533,16 @@
_
(phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: (object::instance? extension-name generate inputs)
+(def: object::instance?
Handler
- (case inputs
- (^ (list (synthesis.text class) objectS))
- (do phase.monad
- [objectI (generate objectS)]
- (wrap (|>> objectI
- (_.INSTANCEOF class)
- (_.wrap #jvm.Boolean))))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+ (..custom
+ [($_ <>.and <s>.text <s>.any)
+ (function (_ extension-name generate [class objectS])
+ (do phase.monad
+ [objectI (generate objectS)]
+ (wrap (|>> objectI
+ (_.INSTANCEOF class)
+ (_.wrap #jvm.Boolean)))))]))
(def: (object::cast extension-name generate inputs)
Handler
@@ -813,20 +801,20 @@
)))
(def: var
- (<s>.Parser Var)
+ (Parser Var)
<s>.text)
(def: bound
- (<s>.Parser Bound)
+ (Parser Bound)
(<>.or (<s>.constant! ["" ">"])
(<s>.constant! ["" "<"])))
(def: (class' generic)
- (-> (<s>.Parser Generic) (<s>.Parser Class))
+ (-> (Parser Generic) (Parser Class))
(<s>.tuple (<>.and <s>.text (<>.some generic))))
(def: generic
- (<s>.Parser Generic)
+ (Parser Generic)
(<>.rec
(function (_ generic)
(let [wildcard (<>.or (<s>.constant! ["" "?"])
@@ -837,11 +825,11 @@
(class' generic))))))
(def: class
- (<s>.Parser Class)
+ (Parser Class)
(class' ..generic))
(def: primitive
- (<s>.Parser Primitive)
+ (Parser Primitive)
($_ <>.or
(<s>.constant! ["" reflection.boolean])
(<s>.constant! ["" reflection.byte])
@@ -854,7 +842,7 @@
))
(def: jvm-type
- (<s>.Parser Type)
+ (Parser Type)
(<>.rec
(function (_ jvm-type)
($_ <>.or
@@ -863,28 +851,28 @@
(<s>.tuple jvm-type)))))
(def: constructor-arg
- (<s>.Parser (Typed Synthesis))
+ (Parser (Typed Synthesis))
(<s>.tuple (<>.and ..jvm-type <s>.any)))
(def: annotation-parameter
- (<s>.Parser (/.Annotation-Parameter Synthesis))
+ (Parser (/.Annotation-Parameter Synthesis))
(<s>.tuple (<>.and <s>.text <s>.any)))
(def: annotation
- (<s>.Parser (/.Annotation Synthesis))
+ (Parser (/.Annotation Synthesis))
(<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
(def: argument
- (<s>.Parser Argument)
+ (Parser Argument)
(<s>.tuple (<>.and <s>.text ..jvm-type)))
(def: return
- (<s>.Parser Return)
+ (Parser Return)
(<>.or (<s>.constant! ["" jvm.void-descriptor])
..jvm-type))
(def: overriden-method-definition
- (<s>.Parser [Environment (/.Overriden-Method Synthesis)])
+ (Parser [Environment (/.Overriden-Method Synthesis)])
(<s>.tuple (do <>.monad
[ownerT ..class
name <s>.text