diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/generator/case.jvm.lux | 162 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 57 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/common.jvm.lux | 5 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/procedure/host.jvm.lux | 33 |
4 files changed, 135 insertions, 122 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux index f20c83f6e..a619768bb 100644 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -1,8 +1,11 @@ (;module: lux - (lux (control [monad #+ do]) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format) [meta "meta/" Monad<Meta>]) - (luxc [";L" host] + (luxc ["_" base] + [";L" host] (lang ["ls" synthesis]) (generator (host ["$" jvm] (jvm ["$t" type] @@ -49,50 +52,52 @@ (list)) false))) -(def: (generate-pattern' generate stack-depth @else @end path) +(exception: #export Unrecognized-Path) + +(def: (generate-path' generate stack-depth @else @end path) (-> (-> ls;Synthesis (Meta $;Inst)) Nat $;Label $;Label ls;Path (Meta $;Inst)) (case path - (#ls;ExecP bodyS) + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (do meta;Monad<Meta> [bodyI (generate bodyS)] (wrap (|>. (pop-altI stack-depth) bodyI ($i;GOTO @end)))) - #ls;UnitP + (^ [_ (#;Form (list [_ (#;Text "lux case pop")]))]) (meta/wrap popI) - (#ls;BindP register) + (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) (meta/wrap (|>. peekI ($i;ASTORE register) popI)) - (#ls;BoolP value) + [_ (#;Bool value)] (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] (|>. peekI ($i;unwrap #$;Boolean) (jumpI @else)))) (^template [<tag> <prep>] - (<tag> value) + [_ (<tag> value)] (meta/wrap (|>. peekI ($i;unwrap #$;Long) ($i;long (|> value <prep>)) $i;LCMP ($i;IFNE @else)))) - ([#ls;NatP (:! Int)] - [#ls;IntP (: Int)] - [#ls;DegP (:! Int)]) + ([#;Nat (:! Int)] + [#;Int (: Int)] + [#;Deg (:! Int)]) - (#ls;FracP value) + [_ (#;Frac value)] (meta/wrap (|>. peekI ($i;unwrap #$;Double) ($i;double value) $i;DCMPL ($i;IFNE @else))) - (#ls;TextP value) + [_ (#;Text value)] (meta/wrap (|>. peekI ($i;string value) ($i;INVOKEVIRTUAL "java.lang.Object" @@ -103,95 +108,88 @@ false) ($i;IFEQ @else))) - (#ls;TupleP idx subP) - (do meta;Monad<Meta> - [subI (generate-pattern' generate stack-depth @else @end subP) - #let [[idx tail?] (case idx - (#;Left idx) - [idx false] - - (#;Right idx) - [idx true])]] - (wrap (case idx - +0 - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int 0) - $i;AALOAD - pushI - subI) - - _ - (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) - ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC hostL;runtime-class - (if tail? "pm_right" "pm_left") - ($t;method (list ../runtime;$Tuple $t;int) - (#;Some $Object) - (list)) - false) - pushI - subI)))) - - (#ls;VariantP idx subP) - (do meta;Monad<Meta> - [subI (generate-pattern' generate stack-depth @else @end subP) - #let [[idx last?] (case idx - (#;Left idx) - [idx false] - - (#;Right idx) - [idx true]) - flagI (if last? - ($i;string "") - $i;NULL)]] - (wrap (<| $i;with-label (function [@success]) - $i;with-label (function [@fail]) + (^template [<special> <method>] + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) + (do meta;Monad<Meta> + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (case idx + +0 + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int 0) + $i;AALOAD + pushI + subI) + + _ (|>. peekI - ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) ($i;int (nat-to-int idx)) - flagI - ($i;INVOKESTATIC hostL;runtime-class "pm_variant" - ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) - (#;Some ../runtime;$Datum) + ($i;INVOKESTATIC hostL;runtime-class + <method> + ($t;method (list ../runtime;$Tuple $t;int) + (#;Some $Object) (list)) false) - $i;DUP - ($i;IFNULL @fail) - ($i;GOTO @success) - ($i;label @fail) - $i;POP - ($i;GOTO @else) - ($i;label @success) pushI - subI)))) - - (#ls;SeqP leftP rightP) + subI))))) + (["lux case tuple left" "pm_left"] + ["lux case tuple right" "pm_right"]) + + (^template [<special> <flag>] + (^ [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat idx)] subP))]) + (do meta;Monad<Meta> + [subI (generate-path' generate stack-depth @else @end subP)] + (wrap (<| $i;with-label (function [@success]) + $i;with-label (function [@fail]) + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;int (nat-to-int idx)) + <flag> + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" + ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) + (#;Some ../runtime;$Datum) + (list)) + false) + $i;DUP + ($i;IFNULL @fail) + ($i;GOTO @success) + ($i;label @fail) + $i;POP + ($i;GOTO @else) + ($i;label @success) + pushI + subI))))) + (["lux case variant left" $i;NULL] + ["lux case variant right" ($i;string "")]) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) (do meta;Monad<Meta> - [leftI (generate-pattern' generate stack-depth @else @end leftP) - rightI (generate-pattern' generate stack-depth @else @end rightP)] + [leftI (generate-path' generate stack-depth @else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] (wrap (|>. leftI rightI))) - (#ls;AltP leftP rightP) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) (do meta;Monad<Meta> [@alt-else $i;make-label - leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP) - rightI (generate-pattern' generate stack-depth @else @end rightP)] + leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-path' generate stack-depth @else @end rightP)] (wrap (|>. $i;DUP leftI ($i;label @alt-else) $i;POP rightI))) - )) -(def: (generate-pattern generate path @end) + _ + (_;throw Unrecognized-Path (%code path)))) + +(def: (generate-path generate path @end) (-> (-> ls;Synthesis (Meta $;Inst)) ls;Path $;Label (Meta $;Inst)) (do meta;Monad<Meta> [@else $i;make-label - pathI (generate-pattern' generate +1 @else @end path)] + pathI (generate-path' generate +1 @else @end path)] (wrap (|>. pathI ($i;label @else) $i;POP @@ -208,7 +206,7 @@ (do meta;Monad<Meta> [@end $i;make-label valueI (generate valueS) - pathI (generate-pattern generate path @end)] + pathI (generate-path generate path @end)] (wrap (|>. valueI $i;NULL $i;SWAP diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 685bf2335..b439ff17a 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -1,9 +1,12 @@ (;module: lux (lux (control monad - ["ex" exception #+ exception:]) - (data text/format) - [meta #+ Monad<Meta> "Meta/" Monad<Meta>]) + ["ex" exception #+ exception:] + ["p" parser]) + (data ["e" error] + text/format) + [meta] + (meta ["s" syntax])) (luxc ["&" base] (lang ["ls" synthesis]) ["&;" analyser] @@ -24,48 +27,52 @@ (def: #export (generate synthesis) (-> ls;Synthesis (Meta $;Inst)) (case synthesis - #ls;Unit + [_ (#;Tuple #;Nil)] &primitive;generate-unit + (^ [_ (#;Tuple (list singleton))]) + (generate singleton) + (^template [<tag> <generator>] - (<tag> value) + [_ (<tag> value)] (<generator> value)) - ([#ls;Bool &primitive;generate-bool] - [#ls;Nat &primitive;generate-nat] - [#ls;Int &primitive;generate-int] - [#ls;Deg &primitive;generate-deg] - [#ls;Frac &primitive;generate-frac] - [#ls;Text &primitive;generate-text]) + ([#;Bool &primitive;generate-bool] + [#;Nat &primitive;generate-nat] + [#;Int &primitive;generate-int] + [#;Deg &primitive;generate-deg] + [#;Frac &primitive;generate-frac] + [#;Text &primitive;generate-text]) - (#ls;Variant tag tail? member) - (&structure;generate-variant generate tag tail? member) + (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] valueS))]) + (&structure;generate-variant generate tag last? valueS) - (#ls;Tuple members) + [_ (#;Tuple members)] (&structure;generate-tuple generate members) - (#ls;Variable var) + (^ [_ (#;Form (list [_ (#;Int var)]))]) (if (functionS;captured? var) (&reference;generate-captured var) (&reference;generate-variable var)) - (#ls;Definition definition) + [_ (#;Symbol definition)] (&reference;generate-definition definition) - (#ls;Let register inputS exprS) + (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS exprS))]) (caseG;generate-let generate register inputS exprS) - (#ls;Case inputS pathPS) + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathPS))]) (caseG;generate-case generate inputS pathPS) - (#ls;Function arity env body) - (&function;generate-function generate env arity body) + (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity)] [_ (#;Tuple environment)] bodyS))]) + [(s;run environment (p;some s;int)) (#e;Success environment)]) + (&function;generate-function generate environment arity bodyS) - (#ls;Call args function) - (&function;generate-call generate function args) + (^ [_ (#;Form (list& [_ (#;Text "lux call")] functionS argsS))]) + (&function;generate-call generate functionS argsS) - (#ls;Procedure name args) - (&procedure;generate-procedure generate name args) + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (&procedure;generate-procedure generate procedure argsS) _ - (&;throw Unrecognized-Synthesis "") + (&;throw Unrecognized-Synthesis (%code synthesis)) )) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index fd76082a6..7ae471c64 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -146,6 +146,10 @@ ($i;CHECKCAST hostL;function-class) ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) +(def: (lux//noop valueI) + Unary + valueI) + ## [[Bits]] (do-template [<name> <op>] [(def: (<name> [inputI maskI]) @@ -536,6 +540,7 @@ (def: lux-procs Bundle (|> (dict;new text;Hash<Text>) + (install "lux noop" (unary lux//noop)) (install "lux is" (binary lux//is)) (install "lux try" (unary lux//try)))) diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index fc6bdd01b..44da5744d 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -37,6 +37,7 @@ [L2S (|>. $i;L2I $i;I2S)] [L2B (|>. $i;L2I $i;I2B)] + [L2C (|>. $i;L2I $i;I2C)] ) (do-template [<name> <unwrap> <conversion> <wrap>] @@ -68,6 +69,7 @@ [convert//long-to-int #$;Long $i;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 $i;I2B #$;Byte] [convert//char-to-short #$;Char $i;I2S #$;Short] [convert//char-to-int #$;Char $i;NOP #$;Int] @@ -97,6 +99,7 @@ (@;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)) @@ -278,7 +281,7 @@ (def: (array//new proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Nat level) (#ls;Text class) lengthS)) + (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) (do meta;Monad<Meta> [lengthI (generate lengthS) #let [arrayJT ($t;array level (case class @@ -302,7 +305,7 @@ (def: (array//read proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) idxS arrayS)) + (^ (list [_ (#;Text class)] idxS arrayS)) (do meta;Monad<Meta> [arrayI (generate arrayS) idxI (generate idxS) @@ -328,7 +331,7 @@ (def: (array//write proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) idxS valueS arrayS)) + (^ (list [_ (#;Text class)] idxS valueS arrayS)) (do meta;Monad<Meta> [arrayI (generate arrayS) idxI (generate idxS) @@ -397,7 +400,7 @@ (def: (object//class proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class))) + (^ (list [_ (#;Text class)])) (do meta;Monad<Meta> [] (wrap (|>. ($i;string class) @@ -413,7 +416,7 @@ (def: (object//instance? proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) objectS)) + (^ (list [_ (#;Text class)] objectS)) (do meta;Monad<Meta> [objectI (generate objectS)] (wrap (|>. objectI @@ -450,7 +453,7 @@ (def: (static//get proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed))) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) (do meta;Monad<Meta> [] (case (dict;get unboxed primitives) @@ -477,7 +480,7 @@ (def: (static//put proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS)) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) (do meta;Monad<Meta> [valueI (generate valueS)] (case (dict;get unboxed primitives) @@ -509,7 +512,7 @@ (def: (virtual//get proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) objectS)) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) (do meta;Monad<Meta> [objectI (generate objectS)] (case (dict;get unboxed primitives) @@ -540,7 +543,7 @@ (def: (virtual//put proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list (#ls;Text class) (#ls;Text field) (#ls;Text unboxed) valueS objectS)) + (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) (do meta;Monad<Meta> [valueI (generate valueS) objectI (generate objectS)] @@ -632,7 +635,7 @@ #;Nil (meta/wrap #;Nil) - (^ (list& [(#ls;Tuple (list (#ls;Text argD) argS))] tail)) + (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) (do meta;Monad<Meta> [argT (generate-type argD) argI (:: @ map (prepare-input argT) (generate argS)) @@ -669,8 +672,8 @@ (def: (invoke//static proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list& (#ls;Text class) (#ls;Text method) - (#ls;Text unboxed) argsS)) + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;Text unboxed)] argsS)) (do meta;Monad<Meta> [argsTI (generate-args generate argsS) returnT (method-return-type unboxed) @@ -687,8 +690,8 @@ [(def: (<name> proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list& (#ls;Text class) (#ls;Text method) - (#ls;Text unboxed) objectS argsS)) + (^ (list& [_ (#;Text class)] [_ (#;Text method)] + [_ (#;Text unboxed)] objectS argsS)) (do meta;Monad<Meta> [objectI (generate objectS) argsTI (generate-args generate argsS) @@ -712,7 +715,7 @@ (def: (invoke//constructor proc generate inputs) (-> Text @;Proc) (case inputs - (^ (list& (#ls;Text class) argsS)) + (^ (list& [_ (#;Text class)] argsS)) (do meta;Monad<Meta> [argsTI (generate-args generate argsS)] (wrap (|>. ($i;NEW class) |