diff options
Diffstat (limited to 'new-luxc')
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 |