diff options
Diffstat (limited to '')
22 files changed, 841 insertions, 820 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) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index dab2d84e6..96053edc0 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -5,40 +5,6 @@ (def: #export Register Nat) (def: #export Variable Int) -(type: #export (Path' s) - #UnitP - (#BoolP Bool) - (#NatP Nat) - (#IntP Int) - (#DegP Deg) - (#FracP Frac) - (#TextP Text) - (#VariantP (Either Nat Nat) (Path' s)) - (#TupleP (Either Nat Nat) (Path' s)) - (#BindP Nat) - (#AltP (Path' s) (Path' s)) - (#SeqP (Path' s) (Path' s)) - (#ExecP s)) +(type: #export Synthesis Code) -(type: #export #rec Synthesis - #Unit - (#Bool Bool) - (#Nat Nat) - (#Int Int) - (#Deg Deg) - (#Frac Frac) - (#Text Text) - (#Variant Nat Bool Synthesis) - (#Tuple (List Synthesis)) - (#Case Synthesis (Path' Synthesis)) - (#Function Arity (List Variable) Synthesis) - (#Call (List Synthesis) Synthesis) - (#Recur (List Synthesis)) - (#Procedure Text (List Synthesis)) - (#Variable Variable) - (#Definition Ident) - (#Let Register Synthesis Synthesis) - (#If Synthesis Synthesis Synthesis) - (#Loop Register (List Synthesis) Synthesis)) - -(type: #export Path (Path' Synthesis)) +(type: #export Path Code) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 011dfd8ae..e1eb67bd7 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -1,11 +1,15 @@ (;module: lux - (lux (data [maybe] + (lux (control ["p" parser]) + (data [maybe] + ["e" error] [number] [product] text/format (coll [list "list/" Functor<List> Fold<List> Monoid<List>] - [dict #+ Dict]))) + [dict #+ Dict])) + (meta [code] + ["s" syntax])) (luxc ["&" base] (lang ["la" analysis] ["ls" synthesis]) @@ -24,6 +28,76 @@ body (&&loop;reify-recursion arity body))) +(def: (parse-environment env) + (-> (List Code) (e;Error (List ls;Variable))) + (s;run env (p;some s;int))) + +(def: (let$ register inputS bodyS) + (-> Nat ls;Synthesis ls;Synthesis ls;Synthesis) + (` ("lux let" (~ (code;nat register)) (~ inputS) (~ bodyS)))) + +(def: (if$ testS thenS elseS) + (-> ls;Synthesis ls;Synthesis ls;Synthesis ls;Synthesis) + (` ("lux if" (~ testS) + (~ thenS) + (~ elseS)))) + +(def: (function$ arity environment body) + (-> ls;Arity (List ls;Variable) ls;Synthesis ls;Synthesis) + (` ("lux function" (~ (code;nat arity)) + [(~@ (list/map code;int environment))] + (~ body)))) + +(def: (variant$ tag last? valueS) + (-> Nat Bool ls;Synthesis ls;Synthesis) + (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS)))) + +(def: (var$ var) + (-> ls;Variable ls;Synthesis) + (` ((~ (code;int var))))) + +(def: (procedure$ name argsS) + (-> Text (List ls;Synthesis) ls;Synthesis) + (` ((~ (code;text name)) (~@ argsS)))) + +(def: (call$ funcS argsS) + (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis) + (` ("lux call" (~ funcS) (~@ argsS)))) + +(def: (synthesize-case synthesize inputA branchesA) + (-> (-> la;Analysis ls;Synthesis) + la;Analysis (List [la;Pattern la;Analysis]) + ls;Synthesis) + (let [inputS (synthesize inputA)] + (case (list;reverse branchesA) + (^multi (^ (list [(#la;BindP input-register) + (#la;Variable (#;Local output-register))])) + (n.= input-register output-register)) + inputS + + (^ (list [(#la;BindP register) bodyA])) + (let$ register inputS (synthesize bodyA)) + + (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA])) + (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA]))) + (if$ inputS (synthesize thenA) (synthesize elseA)) + + (#;Cons [lastP lastA] prevsPA) + (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) + (function [pattern expr] + (|> (synthesize expr) + (~) ("lux case exec") + ("lux case seq" (~ (&&case;path pattern))) + (`))))] + (` ("lux case" (~ inputS) + (~ (list/fold &&case;weave + (transform-branch lastP lastA) + (list/map (product;uncurry transform-branch) prevsPA)))))) + + _ + (undefined) + ))) + (def: #export (synthesize analysis) (-> la;Analysis ls;Synthesis) (loop [outer-arity +0 @@ -31,71 +105,43 @@ num-locals +0 exprA analysis] (case exprA + #la;Unit + (' []) + (^template [<from> <to>] (<from> value) (<to> value)) - ([#la;Unit #ls;Unit] - [#la;Bool #ls;Bool] - [#la;Nat #ls;Nat] - [#la;Int #ls;Int] - [#la;Deg #ls;Deg] - [#la;Frac #ls;Frac] - [#la;Text #ls;Text] - [#la;Definition #ls;Definition]) + ([#la;Bool code;bool] + [#la;Nat code;nat] + [#la;Int code;int] + [#la;Deg code;deg] + [#la;Frac code;frac] + [#la;Text code;text] + [#la;Definition code;symbol]) (#la;Product _) - (#ls;Tuple (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA))) + (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))]) (#la;Sum choice) (let [[tag last? value] (&&structure;unfold-variant choice)] - (#ls;Variant tag last? (recur +0 resolver num-locals value))) + (variant$ tag last? (recur +0 resolver num-locals value))) (#la;Variable ref) (case ref (#;Local register) (if (&&function;nested? outer-arity) (if (n.= +0 register) - (#ls;Call (|> (list;n.range +1 (n.dec outer-arity)) - (list/map (|>. &&function;to-local #ls;Variable))) - (#ls;Variable 0)) - (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register)))) - (#ls;Variable (&&function;to-local register))) + (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) + (list/map (|>. &&function;to-local code;int (~) () (`))))) + (var$ (&&function;adjust-var outer-arity (&&function;to-local register)))) + (var$ (&&function;to-local register))) (#;Captured register) - (#ls;Variable (let [var (&&function;to-captured register)] - (maybe;default var (dict;get var resolver))))) + (var$ (let [var (&&function;to-captured register)] + (maybe;default var (dict;get var resolver))))) (#la;Case inputA branchesA) - (let [inputS (recur +0 resolver num-locals inputA)] - (case (list;reverse branchesA) - (^multi (^ (list [(#la;BindP input-register) - (#la;Variable (#;Local output-register))])) - (n.= input-register output-register)) - inputS - - (^ (list [(#la;BindP register) bodyA])) - (#ls;Let register inputS (recur +0 resolver num-locals bodyA)) - - (^or (^ (list [(#la;BoolP true) thenA] [(#la;BoolP false) elseA])) - (^ (list [(#la;BoolP false) elseA] [(#la;BoolP true) thenA]))) - (#ls;If inputS - (recur +0 resolver num-locals thenA) - (recur +0 resolver num-locals elseA)) - - (#;Cons [lastP lastA] prevsPA) - (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) - (function [pattern expr] - (|> (recur +0 resolver num-locals expr) - #ls;ExecP - (#ls;SeqP (&&case;path pattern)))))] - (#ls;Case inputS - (list/fold &&case;weave - (transform-branch lastP lastA) - (list/map (product;uncurry transform-branch) prevsPA)))) - - _ - (undefined) - )) + (synthesize-case (recur +0 resolver num-locals) inputA branchesA) (#la;Function scope bodyA) (let [inner-arity (n.inc outer-arity) @@ -116,33 +162,34 @@ init-resolver env-vars))] (case (recur inner-arity resolver' +0 bodyA) - (#ls;Function arity' env' bodyS') + (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))]) (let [arity (n.inc arity')] - (#ls;Function arity env (prepare-body inner-arity arity bodyS'))) + (function$ arity env (prepare-body inner-arity arity bodyS'))) bodyS - (#ls;Function +1 env (prepare-body inner-arity +1 bodyS)))) + (function$ +1 env (prepare-body inner-arity +1 bodyS)))) (#la;Apply _) (let [[funcA argsA] (&&function;unfold-apply exprA) funcS (recur +0 resolver num-locals funcA) argsS (list/map (recur +0 resolver num-locals) argsA)] (case funcS - (^multi (#ls;Function _arity _env _bodyS) + (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))]) (and (n.= _arity (list;size argsS)) - (not (&&loop;contains-self-reference? _bodyS)))) + (not (&&loop;contains-self-reference? _bodyS))) + [(parse-environment _env) (#e;Success _env)]) (let [register-offset (if (&&function;top? outer-arity) num-locals (|> outer-arity n.inc (n.+ num-locals)))] - (#ls;Loop register-offset argsS - (&&loop;adjust _env register-offset _bodyS))) + (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] + (~ (&&loop;adjust _env register-offset _bodyS))))) - (#ls;Call argsS' funcS') - (#ls;Call (list/compose argsS' argsS) funcS') + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) + (call$ funcS' (list/compose argsS' argsS)) _ - (#ls;Call argsS funcS))) + (call$ funcS argsS))) (#la;Procedure name args) - (#ls;Procedure name (list/map (recur +0 resolver num-locals) args)) + (procedure$ name (list/map (recur +0 resolver num-locals) args)) ))) diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux index 02b1bfba5..91f339bdf 100644 --- a/new-luxc/source/luxc/synthesizer/case.lux +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -1,10 +1,10 @@ (;module: lux - (lux (data [bool "B/" Eq<Bool>] - [text "T/" Eq<Text>] + (lux (data [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>] [number] - (coll [list "L/" Functor<List> Fold<List> Monoid<List>] - ["s" set]))) + (coll [list "list/" Fold<List>])) + (meta [code "code/" Eq<Code>])) (luxc (lang ["la" analysis] ["ls" synthesis]) (synthesizer ["&;" function]))) @@ -12,21 +12,23 @@ (def: #export (path pattern) (-> la;Pattern ls;Path) (case pattern + (#la;BindP register) + (` ("lux case bind" (~ (code;nat register)))) + (^template [<from> <to>] - (<from> register) - (<to> register)) - ([#la;BindP #ls;BindP] - [#la;BoolP #ls;BoolP] - [#la;NatP #ls;NatP] - [#la;IntP #ls;IntP] - [#la;DegP #ls;DegP] - [#la;FracP #ls;FracP] - [#la;TextP #ls;TextP]) + (<from> value) + (<to> value)) + ([#la;BoolP code;bool] + [#la;NatP code;nat] + [#la;IntP code;int] + [#la;DegP code;deg] + [#la;FracP code;frac] + [#la;TextP code;text]) (#la;TupleP membersP) (case (list;reverse membersP) #;Nil - #ls;UnitP + (' ("lux case pop")) (#;Cons singletonP #;Nil) (path singletonP) @@ -34,58 +36,46 @@ (#;Cons lastP prevsP) (let [length (list;size membersP) last-idx (n.dec length) - last-path (#ls;TupleP (#;Right last-idx) (path lastP)) - [_ tuple-path] (L/fold (function [current-pattern [current-idx next-path]] - [(n.dec current-idx) - (#ls;SeqP (#ls;TupleP (#;Left current-idx) - (path current-pattern)) - next-path)]) - [(n.dec last-idx) last-path] - prevsP)] + [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]] + [(n.dec current-idx) + (` ("lux case seq" + ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern))) + (~ next-path)))]) + [(n.dec last-idx) + (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))] + prevsP)] tuple-path)) (#la;VariantP tag num-tags memberP) - (let [last? (n.= (n.dec num-tags) tag)] - (#ls;VariantP (if last? (#;Right tag) (#;Left tag)) - (path memberP))))) + (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP)))) + (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP))))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) - (with-expansions [<default> (as-is (#ls;AltP leftP rightP))] + (with-expansions [<default> (as-is (` ("lux case alt" (~ leftP) (~ rightP))))] (case [leftP rightP] - [#ls;UnitP #ls;UnitP] - #ls;UnitP - - (^template [<tag> <test>] - [(<tag> left) (<tag> right)] - (if (<test> left right) - leftP - <default>)) - ([#ls;BindP n.=] - [#ls;BoolP B/=] - [#ls;NatP n.=] - [#ls;IntP i.=] - [#ls;DegP d.=] - [#ls;FracP f.=] - [#ls;TextP T/=]) - - (^template [<tag> <side>] - [(<tag> (<side> left-idx) left-then) (<tag> (<side> right-idx) right-then)] + (^template [<special>] + (^ [[_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat left-idx)] left-then))] + [_ (#;Form (list [_ (#;Text <special>)] [_ (#;Nat right-idx)] right-then))]]) (if (n.= left-idx right-idx) - (weave left-then right-then) + (` (<special> (~ (code;nat left-idx)) (~ (weave left-then right-then)))) <default>)) - ([#ls;TupleP #;Left] - [#ls;TupleP #;Right] - [#ls;VariantP #;Left] - [#ls;VariantP #;Right]) + (["lux case tuple left"] + ["lux case tuple right"] + ["lux case variant left"] + ["lux case variant right"]) - [(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)] + (^ [[_ (#;Form (list [_ (#;Text "lux case seq")] left-pre left-post))] + [_ (#;Form (list [_ (#;Text "lux case seq")] right-pre right-post))]]) (case (weave left-pre right-pre) - (#ls;AltP _ _) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] _ _))]) <default> weavedP - (#ls;SeqP weavedP (weave left-post right-post))) + (` ("lux case seq" (~ weavedP) (~ (weave left-post right-post))))) _ - <default>))) + (if (code/= leftP rightP) + leftP + <default>)))) diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux index ad4504f41..8599db981 100644 --- a/new-luxc/source/luxc/synthesizer/loop.lux +++ b/new-luxc/source/luxc/synthesizer/loop.lux @@ -1,61 +1,71 @@ (;module: lux - (lux (data [maybe] - text/format - (coll [list "L/" Functor<List>]))) + (lux (control [monad #+ do] + ["p" parser]) + (data [maybe] + (coll [list "list/" Functor<List>])) + (meta [code] + [syntax])) (luxc (lang ["ls" synthesis]) (synthesizer ["&&;" function]))) (def: #export (contains-self-reference? exprS) (-> ls;Synthesis Bool) (case exprS - (#ls;Variant tag last? memberS) + (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] memberS))]) (contains-self-reference? memberS) - (#ls;Tuple membersS) + [_ (#;Tuple membersS)] (list;any? contains-self-reference? membersS) - (#ls;Case inputS pathS) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (&&function;self? var) + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) (or (contains-self-reference? inputS) (loop [pathS pathS] (case pathS - (^or (#ls;AltP leftS rightS) - (#ls;SeqP leftS rightS)) + (^or (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))])) (or (recur leftS) (recur rightS)) - - (#ls;ExecP bodyS) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (contains-self-reference? bodyS) _ false))) - (#ls;Function arity environment bodyS) - (list;any? &&function;self? environment) - - (#ls;Call argsS funcS) + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (list;any? (function [captured] + (case captured + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (&&function;self? var) + + _ + false)) + environment) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) (or (contains-self-reference? funcS) (list;any? contains-self-reference? argsS)) - - (^or (#ls;Recur argsS) - (#ls;Procedure name argsS)) - (list;any? contains-self-reference? argsS) - - (#ls;Variable idx) - (&&function;self? idx) - (#ls;Let register inputS bodyS) + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) (or (contains-self-reference? inputS) (contains-self-reference? bodyS)) - (#ls;If inputS thenS elseS) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) (or (contains-self-reference? inputS) (contains-self-reference? thenS) (contains-self-reference? elseS)) - (#ls;Loop offset argsS bodyS) - (or (list;any? contains-self-reference? argsS) + (^ [_ (#;Form (list [_ (#;Text "lux loop")] offset [_ (#;Tuple initsS)] bodyS))]) + (or (list;any? contains-self-reference? initsS) (contains-self-reference? bodyS)) + + (^or (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])) + (list;any? contains-self-reference? argsS) _ false @@ -65,37 +75,34 @@ (-> Nat ls;Synthesis ls;Synthesis) (loop [exprS exprS] (case exprS - (#ls;Case inputS pathS) - (#ls;Case inputS - (let [reify-recursion' recur] - (loop [pathS pathS] - (case pathS - (#ls;AltP leftS rightS) - (#ls;AltP (recur leftS) (recur rightS)) - - (#ls;SeqP leftS rightS) - (#ls;SeqP leftS (recur rightS)) - - (#ls;ExecP bodyS) - (#ls;ExecP (reify-recursion' bodyS)) - - _ - pathS)))) - - (^multi (#ls;Call argsS (#ls;Variable 0)) + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (` ("lux case" (~ inputS) + (~ (let [reify-recursion' recur] + (loop [pathS pathS] + (case pathS + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) + (` ("lux case alt" (~ (recur leftS)) (~ (recur rightS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))]) + (` ("lux case seq" (~ leftS) (~ (recur rightS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (` ("lux case exec" (~ (reify-recursion' bodyS)))) + + _ + pathS)))))) + + (^multi (^ [_ (#;Form (list& [_ (#;Text "lux call")] + [_ (#;Form (list [_ (#;Int 0)]))] + argsS))]) (n.= arity (list;size argsS))) - (#ls;Recur argsS) + (` ("lux recur" (~@ argsS))) - (#ls;Call argsS (#ls;Variable var)) - exprS + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) + (` ("lux let" (~ register) (~ inputS) (~ (recur bodyS)))) - (#ls;Let register inputS bodyS) - (#ls;Let register inputS (recur bodyS)) - - (#ls;If inputS thenS elseS) - (#ls;If inputS - (recur thenS) - (recur elseS)) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ inputS) (~ (recur thenS)) (~ (recur elseS)))) _ exprS @@ -109,58 +116,69 @@ (|> env (list;nth idx) maybe;assume))))] (loop [exprS exprS] (case exprS - (#ls;Variant tag last? valueS) - (#ls;Variant tag last? (recur valueS)) + (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))]) + (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) - (#ls;Tuple members) - (#ls;Tuple (L/map recur members)) - - (#ls;Case inputS pathS) - (#ls;Case (recur inputS) - (let [adjust' recur] - (loop [pathS pathS] - (case pathS - (^template [<tag>] - (<tag> leftS rightS) - (<tag> (recur leftS) (recur rightS))) - ([#ls;AltP] - [#ls;SeqP]) - - (#ls;ExecP bodyS) - (#ls;ExecP (adjust' bodyS)) - - _ - pathS)))) - - (#ls;Function arity scope bodyS) - (#ls;Function arity - (L/map resolve-captured scope) - (recur bodyS)) - - (#ls;Call argsS funcS) - (#ls;Call (L/map recur argsS) (recur funcS)) - - (#ls;Recur argsS) - (#ls;Recur (L/map recur argsS)) - - (#ls;Procedure name argsS) - (#ls;Procedure name (L/map recur argsS)) - - (#ls;Variable var) - (if (&&function;captured? var) - (#ls;Variable (resolve-captured var)) - (#ls;Variable (|> outer-offset nat-to-int (i.+ var)))) - - (#ls;Let register inputS bodyS) - (#ls;Let (n.+ outer-offset register) (recur inputS) (recur bodyS)) - - (#ls;If inputS thenS elseS) - (#ls;If (recur inputS) (recur thenS) (recur elseS)) + [_ (#;Tuple members)] + [_ (#;Tuple (list/map recur members))] + + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (` ("lux case" (~ (recur inputS)) + (~ (let [adjust' recur] + (loop [pathS pathS] + (case pathS + (^template [<pattern>] + (^ [_ (#;Form (list [_ (#;Text <pattern>)] leftS rightS))]) + (` (<pattern> (~ (recur leftS)) (~ (recur rightS))))) + (["lux case alt"] + ["lux case seq"]) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) + (` ("lux case exec" (~ (adjust' bodyS)))) + + _ + pathS)))))) + + (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (` ("lux function" (~ arity) + (~ [_ (#;Tuple (list/map (function [_var] + (case _var + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (` ((~ (code;int (resolve-captured var))))) + + _ + _var)) + environment))]) + (~ (recur bodyS)))) + + (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) + (` ("lux call" (~ (recur funcS)) (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) + (` ("lux recur" (~@ (list/map recur argsS)))) + + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (` ((~ (code;text procedure)) (~@ (list/map recur argsS)))) - (#ls;Loop inner-offset argsS bodyS) - (#ls;Loop (n.+ outer-offset inner-offset) - (L/map recur argsS) - (recur bodyS)) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (if (&&function;captured? var) + (` ((~ (code;int (resolve-captured var))))) + (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var))))))) + + (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))]) + (` ("lux let" (~ (code;nat (n.+ outer-offset register))) + (~ (recur inputS)) + (~ (recur bodyS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) + (` ("lux if" (~ (recur inputS)) + (~ (recur thenS)) + (~ (recur elseS)))) + + (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))]) + (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset))) + [(~@ (list/map recur initsS))] + (~ (recur bodyS)))) _ exprS diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux index f9e165c03..ff0e017aa 100644 --- a/new-luxc/test/test/luxc/generator/case.lux +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -4,9 +4,11 @@ (control [monad #+ do] pipe) (data ["e" error] + text/format (coll [list])) ["r" math/random "r/" Monad<Random>] [meta] + (meta [code]) test) (luxc (lang ["ls" synthesis]) [analyser] @@ -28,46 +30,44 @@ (r;Random [ls;Synthesis ls;Path]) (<| r;rec (function [gen-case]) (`` ($_ r;either - (r/wrap [#ls;Unit #ls;UnitP]) - (~~ (do-template [<gen> <synth> <path>] + (r/wrap [(' []) (' ("lux case pop"))]) + (~~ (do-template [<gen> <synth>] [(do r;Monad<Random> [value <gen>] - (wrap [(<synth> value) (<path> value)]))] + (wrap [(<synth> value) (<synth> value)]))] - [r;bool #ls;Bool #ls;BoolP] - [r;nat #ls;Nat #ls;NatP] - [r;int #ls;Int #ls;IntP] - [r;deg #ls;Deg #ls;DegP] - [r;frac #ls;Frac #ls;FracP] - [(r;text +5) #ls;Text #ls;TextP])) + [r;bool code;bool] + [r;nat code;nat] + [r;int code;int] + [r;deg code;deg] + [r;frac code;frac] + [(r;text +5) code;text])) (do r;Monad<Random> [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) idx (|> r;nat (:: @ map (n.% size))) [subS subP] gen-case - #let [caseS (#ls;Tuple (list;concat (list (list;repeat idx #ls;Unit) - (list subS) - (list;repeat (|> size n.dec (n.- idx)) #ls;Unit)))) - caseP (#ls;TupleP (if (tail? size idx) - (#;Right idx) - (#;Left idx)) - subP)]] + #let [caseS (` [(~@ (list;concat (list (list;repeat idx (' [])) + (list subS) + (list;repeat (|> size n.dec (n.- idx)) (' [])))))]) + caseP (if (tail? size idx) + (` ("lux case tuple right" (~ (code;nat idx)) (~ subP))) + (` ("lux case tuple left" (~ (code;nat idx)) (~ subP))))]] (wrap [caseS caseP])) (do r;Monad<Random> [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) idx (|> r;nat (:: @ map (n.% size))) [subS subP] gen-case - #let [caseS (#ls;Variant idx (tail? idx idx) subS) - caseP (#ls;VariantP (if (tail? idx idx) - (#;Right idx) - (#;Left idx)) - subP)]] + #let [caseS (` ((~ (code;nat idx)) (~ (code;bool (tail? size idx))) (~ subS))) + caseP (if (tail? size idx) + (` ("lux case variant right" (~ (code;nat idx)) (~ subP))) + (` ("lux case variant left" (~ (code;nat idx)) (~ subP))))]] (wrap [caseS caseP])) )))) (context: "Pattern-matching." (<| (times +100) (do @ - [[valueS path] gen-case + [[valueS pathS] gen-case to-bind r;nat] ($_ seq (test "Can generate pattern-matching." @@ -75,21 +75,25 @@ [runtime-bytecode @runtime;generate sampleI (@;generate-case exprG;generate valueS - (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) - (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))] + (` ("lux case alt" + ("lux case seq" (~ pathS) + ("lux case exec" true)) + ("lux case seq" ("lux case bind" +0) + ("lux case exec" false)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) (:! Bool valueG) - _ + (#e;Error error) false))) (test "Can bind values." (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate sampleI (@;generate-case exprG;generate - (#ls;Nat to-bind) - (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))] + (code;nat to-bind) + (` ("lux case seq" ("lux case bind" +0) + ("lux case exec" (0)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux index dfc1230be..1f922706c 100644 --- a/new-luxc/test/test/luxc/generator/function.lux +++ b/new-luxc/test/test/luxc/generator/function.lux @@ -33,7 +33,8 @@ (do r;Monad<Random> [arity arity arg (|> r;nat (:: @ map (n.% arity))) - #let [functionS (#ls;Function arity (list) (#ls;Variable (nat-to-int (n.inc arg))))]] + #let [functionS (` ("lux function" (~ (code;nat arity)) [] + ((~ (code;int (nat-to-int (n.inc arg)))))))]] (wrap [arity arg functionS]))) (context: "Function." @@ -43,14 +44,14 @@ cut-off (|> r;nat (:: @ map (n.% arity))) args (r;list arity r;nat) #let [arg-value (maybe;assume (list;nth arg args)) - argsS (list/map (|>. #ls;Nat) args) + argsS (list/map code;nat args) last-arg (n.dec arity) cut-off (|> cut-off (n.min (n.dec last-arg)))]] ($_ seq (test "Can read arguments." (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@expr;generate (#ls;Call argsS functionS))] + sampleI (@expr;generate (` ("lux call" (~ functionS) (~@ argsS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -65,7 +66,9 @@ preS (list;take partial-arity argsS) postS (list;drop partial-arity argsS)] runtime-bytecode @runtime;generate - sampleI (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS)))] + sampleI (@expr;generate (` ("lux call" + ("lux call" (~ functionS) (~@ preS)) + (~@ postS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -83,11 +86,11 @@ (|> arg n.inc nat-to-int (i.* -1)) (|> arg n.inc (n.- super-arity) nat-to-int)) sub-arity (|> arity (n.- super-arity)) - functionS (<| (#ls;Function super-arity (list)) - (#ls;Function sub-arity env) - (#ls;Variable arg-var))] + functionS (` ("lux function" (~ (code;nat super-arity)) [] + ("lux function" (~ (code;nat sub-arity)) [(~@ (list/map code;int env))] + ((~ (code;int arg-var))))))] runtime-bytecode @runtime;generate - sampleI (@expr;generate (#ls;Call argsS functionS))] + sampleI (@expr;generate (` ("lux call" (~ functionS) (~@ argsS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index 66eacca27..37f87829b 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -9,6 +9,7 @@ [text "T/" Eq<Text>]) ["r" math/random] [meta] + (meta [code]) test) (luxc [";L" host] (lang ["ls" synthesis]) @@ -42,16 +43,16 @@ _ false)))] - ["bool" Bool #ls;Bool %bool% B/=] - ["nat" Nat #ls;Nat %nat% n.=] - ["int" Int #ls;Int %int% i.=] - ["deg" Deg #ls;Deg %deg% d.=] - ["frac" Frac #ls;Frac %frac% f.=] - ["text" Text #ls;Text %text% T/=])] + ["bool" Bool code;bool %bool% B/=] + ["nat" Nat code;nat %nat% n.=] + ["int" Int code;int %int% i.=] + ["deg" Deg code;deg %deg% d.=] + ["frac" Frac code;frac %frac% f.=] + ["text" Text code;text %text% T/=])] ($_ seq (test "Can generate unit." (|> (do meta;Monad<Meta> - [sampleI (@;generate #ls;Unit)] + [sampleI (@;generate (' []))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) diff --git a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux index dde15b19b..7e36575d8 100644 --- a/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/common.jvm.lux @@ -12,7 +12,8 @@ (coll ["a" array] [list])) ["r" math/random] - [meta #+ Monad<Meta>] + [meta] + (meta [code]) [host] test) (luxc (lang ["ls" synthesis]) @@ -32,9 +33,8 @@ (with-expansions [<binary> (do-template [<name> <reference>] [(test <name> (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> - (list (#ls;Nat subject) - (#ls;Nat param))))] + [sampleI (@;generate (` (<name> (~ (code;nat subject)) + (~ (code;nat param)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -52,7 +52,7 @@ ($_ seq (test "bit count" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "bit count" (list (#ls;Nat subject))))] + [sampleI (@;generate (` ("bit count" (~ (code;nat subject)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -64,9 +64,9 @@ <binary> (test "bit shift-right" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "bit shift-right" - (list (#ls;Int (nat-to-int subject)) - (#ls;Nat param))))] + [sampleI (@;generate (` ("bit shift-right" + (~ (code;int (nat-to-int subject))) + (~ (code;nat param)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -82,64 +82,59 @@ (do @ [param (|> r;nat (r;filter (|>. (n.= +0) not))) subject r;nat] - (with-expansions [<nullary> (do-template [<name> <reference>] - [(test <name> - (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> (list)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= <reference> (:! Nat valueG)) + (`` ($_ seq + (~~ (do-template [<name> <reference>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (@;generate (` (<name>)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= <reference> (:! Nat valueG)) - _ - false)))] + _ + false)))] - ["nat min" nat/bottom] - ["nat max" nat/top] - ) - <unary> (do-template [<name> <type> <prepare> <comp>] - [(test <name> - (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> (list (#ls;Nat subject))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (<comp> (<prepare> subject) (:! <type> valueG)) + ["nat min" nat/bottom] + ["nat max" nat/top] + )) + (~~ (do-template [<name> <type> <prepare> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [sampleI (@;generate (` (<name> (~ (code;nat subject)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (<comp> (<prepare> subject) (:! <type> valueG)) - _ - false)))] + _ + false)))] - ["nat to-int" Int nat-to-int i.=] - ["nat to-char" Text text;from-code text/=] - ) - <binary> (do-template [<name> <reference> <outputT> <comp>] - [(test <name> - (|> (do Monad<Meta> - [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> - (list (#ls;Nat subject) - (#ls;Nat param))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (<comp> (<reference> param subject) (:! <outputT> valueG)) + ["nat to-int" Int nat-to-int i.=] + ["nat to-char" Text text;from-code text/=] + )) + (~~ (do-template [<name> <reference> <outputT> <comp>] + [(test <name> + (|> (do meta;Monad<Meta> + [runtime-bytecode @runtime;generate + sampleI (@;generate (` (<name> (~ (code;nat subject)) (~ (code;nat param)))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (<comp> (<reference> param subject) (:! <outputT> valueG)) - _ - false)))] + _ + false)))] - ["nat +" n.+ Nat n.=] - ["nat -" n.- Nat n.=] - ["nat *" n.* Nat n.=] - ["nat /" n./ Nat n.=] - ["nat %" n.% Nat n.=] - ["nat =" n.= Bool bool/=] - ["nat <" n.< Bool bool/=] - )] - ($_ seq - <nullary> - <unary> - <binary> - ))))) + ["nat +" n.+ Nat n.=] + ["nat -" n.- Nat n.=] + ["nat *" n.* Nat n.=] + ["nat /" n./ Nat n.=] + ["nat %" n.% Nat n.=] + ["nat =" n.= Bool bool/=] + ["nat <" n.< Bool bool/=] + )) + ))))) (context: "Int procedures" (<| (times +100) @@ -149,7 +144,7 @@ (with-expansions [<nullary> (do-template [<name> <reference>] [(test <name> (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> (list)))] + [sampleI (@;generate (` (<name>)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -164,7 +159,7 @@ <unary> (do-template [<name> <type> <prepare> <comp>] [(test <name> (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> (list (#ls;Int subject))))] + [sampleI (@;generate (` (<name> (~ (code;int subject)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -178,11 +173,9 @@ ) <binary> (do-template [<name> <reference> <outputT> <comp>] [(test <name> - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> - (list (#ls;Int subject) - (#ls;Int param))))] + sampleI (@;generate (` (<name> (~ (code;int subject)) (~ (code;int param)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -212,11 +205,9 @@ subject r;frac] (with-expansions [<binary> (do-template [<name> <reference> <outputT> <comp>] [(test <name> - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> - (list (#ls;Frac subject) - (#ls;Frac param))))] + sampleI (@;generate (` (<name> (~ (code;frac subject)) (~ (code;frac param)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -245,7 +236,7 @@ (with-expansions [<nullary> (do-template [<name> <test>] [(test <name> (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> (list)))] + [sampleI (@;generate (` (<name>)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -263,9 +254,9 @@ ) <unary> (do-template [<name> <type> <prepare> <comp>] [(test <name> - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> (list (#ls;Frac subject))))] + sampleI (@;generate (` (<name> (~ (code;frac subject)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -281,11 +272,9 @@ <nullary> <unary> (test "frac encode|decode" - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (|> (#ls;Frac subject) - (list) (#ls;Procedure "frac encode") - (list) (#ls;Procedure "frac decode")))] + sampleI (@;generate (` ("frac decode" ("frac encode" (~ (code;frac subject))))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (^multi (#e;Success valueG) @@ -313,7 +302,7 @@ (~~ (do-template [<name> <reference>] [(test <name> (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <name> (list)))] + [sampleI (@;generate (` (<name>)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -327,9 +316,9 @@ )) (~~ (do-template [<name> <type> <prepare> <comp>] [(test <name> - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> (list (#ls;Deg subject))))] + sampleI (@;generate (` (<name> (~ (code;deg subject)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -342,11 +331,9 @@ )) (~~ (do-template [<name> <reference> <outputT> <comp>] [(test <name> - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> - (list (#ls;Deg subject) - (#ls;Deg param))))] + sampleI (@;generate (` (<name> (~ (code;deg subject)) (~ (code;deg param)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -365,11 +352,9 @@ )) (~~ (do-template [<name> <reference> <outputT> <comp>] [(test <name> - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Procedure <name> - (list (#ls;Deg subject) - (#ls;Nat special))))] + sampleI (@;generate (` (<name> (~ (code;deg subject)) (~ (code;nat special)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index 7a047dff9..153f276cc 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -12,7 +12,8 @@ text/format (coll [list])) ["r" math/random "r/" Monad<Random>] - [meta #+ Monad<Meta>] + [meta] + (meta [code]) [host] test) (luxc [";L" host] @@ -33,9 +34,7 @@ (with-expansions [<2step> (do-template [<step1> <step2> <tag> <sample> <cast> <test>] [(test (format <step1> " / " <step2>) (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (<tag> <sample>) - (list) (#ls;Procedure <step1>) - (list) (#ls;Procedure <step2>)))] + [sampleI (@;generate (|> (~ (<tag> <sample>)) <step1> <step2> (`)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -44,14 +43,14 @@ (#e;Error error) false)))] - ["jvm convert double-to-float" "jvm convert float-to-double" #ls;Frac frac-sample Frac f.=] - ["jvm convert double-to-int" "jvm convert int-to-double" #ls;Frac frac-sample Frac f.=] - ["jvm convert double-to-long" "jvm convert long-to-double" #ls;Frac frac-sample Frac f.=] + ["jvm convert double-to-float" "jvm convert float-to-double" code;frac frac-sample Frac f.=] + ["jvm convert double-to-int" "jvm convert int-to-double" code;frac frac-sample Frac f.=] + ["jvm convert double-to-long" "jvm convert long-to-double" code;frac frac-sample Frac f.=] - ["jvm convert long-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] + ["jvm convert long-to-float" "jvm convert float-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] )] ($_ seq <2step> @@ -62,52 +61,50 @@ (do @ [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) #let [frac-sample (int-to-frac int-sample)]] - (with-expansions [<3step> (do-template [<step1> <step2> <step3> <tag> <sample> <cast> <test>] - [(test (format <step1> " / " <step2> " / " <step3>) - (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (<tag> <sample>) - (list) (#ls;Procedure <step1>) - (list) (#ls;Procedure <step2>) - (list) (#ls;Procedure <step3>)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (<test> <sample> (:! <cast> valueG)) - - (#e;Error error) - false)))] - - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-float" "jvm convert float-to-long" #ls;Int int-sample Int i.=] - ) - <4step> (do-template [<step1> <step2> <step3> <step4> <tag> <sample> <cast> <test>] - [(test (format <step1> " / " <step2> " / " <step3>) - (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (<tag> <sample>) - (list) (#ls;Procedure <step1>) - (list) (#ls;Procedure <step2>) - (list) (#ls;Procedure <step3>) - (list) (#ls;Procedure <step4>)))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (<test> <sample> (:! <cast> valueG)) - - (#e;Error error) - false)))] - - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-short" "jvm convert short-to-long" #ls;Int int-sample Int i.=] - ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-int" "jvm convert int-to-long" #ls;Int int-sample Int i.=] - ) - ] - ($_ seq - <3step> - <4step> - ))))) + (`` ($_ seq + (~~ (do-template [<step1> <step2> <step3> <tag> <sample> <cast> <test>] + [(test (format <step1> " / " <step2> " / " <step3>) + (|> (do meta;Monad<Meta> + [sampleI (@;generate (|> (~ (<tag> <sample>)) <step1> <step2> <step3> (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (<test> <sample> (:! <cast> valueG)) + + (#e;Error error) + false)))] + + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-float" "jvm convert float-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-float" "jvm convert float-to-long" code;int int-sample Int i.=] + )) + ))))) + +(context: "Conversions [Part 3]" + (<| (times +100) + (do @ + [int-sample (|> r;int (:: @ map (|>. (i.% 128) int/abs))) + #let [frac-sample (int-to-frac int-sample)]] + (`` ($_ seq + (~~ (do-template [<step1> <step2> <step3> <step4> <tag> <sample> <cast> <test>] + [(test (format <step1> " / " <step2> " / " <step3>) + (|> (do meta;Monad<Meta> + [sampleI (@;generate (|> (~ (<tag> <sample>)) <step1> <step2> <step3> <step4> (`)))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (<test> <sample> (:! <cast> valueG)) + + (#e;Error error) + false)))] + + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-byte" "jvm convert byte-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-short" "jvm convert short-to-long" code;int int-sample Int i.=] + ["jvm convert long-to-int" "jvm convert int-to-char" "jvm convert char-to-int" "jvm convert int-to-long" code;int int-sample Int i.=] + )) + ))))) (def: gen-nat (r;Random Nat) @@ -132,8 +129,9 @@ (with-expansions [<tests> (do-template [<procedure> <reference>] [(test <procedure> (|> (do meta;Monad<Meta> - [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<pre> (<tag> subject)) - (<pre> (<tag> param))))))] + [sampleI (@;generate (` (<post> ((~ (code;text <procedure>)) + (<pre> (~ (<tag> subject))) + (<pre> (~ (<tag> param)))))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -153,64 +151,75 @@ <tests> )))))] - ["int" gen-int #ls;Int Int i.= (i.* 10) i.+ i.- i.* i./ i.% (|>. (list) (#ls;Procedure "jvm convert long-to-int")) (|>. (list) (#ls;Procedure "jvm convert int-to-long"))] - ["long" gen-int #ls;Int Int i.= (i.* 10) i.+ i.- i.* i./ i.% id id] - ["float" gen-frac #ls;Frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% (|>. (list) (#ls;Procedure "jvm convert double-to-float")) (|>. (list) (#ls;Procedure "jvm convert float-to-double"))] - ["double" gen-frac #ls;Frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% id id] + ["int" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "jvm convert long-to-int" "jvm convert int-to-long"] + ["long" gen-int code;int Int i.= (i.* 10) i.+ i.- i.* i./ i.% "lux noop" "lux noop"] + ["float" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "jvm convert double-to-float" "jvm convert float-to-double"] + ["double" gen-frac code;frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% "lux noop" "lux noop"] + ) + +(do-template [<domain> <post> <convert>] + [(context: (format "Bit-wise [" <domain> "] { Combiners ]") + (<| (times +100) + (do @ + [param gen-nat + subject gen-nat] + (`` ($_ seq + (~~ (do-template [<procedure> <reference>] + [(test <procedure> + (|> (do meta;Monad<Meta> + [sampleI (@;generate (` (<post> ((~ (code;text <procedure>)) + (<convert> (~ (code;nat subject))) + (<convert> (~ (code;nat param)))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (n.= (<reference> param subject) + (:! Nat valueG)) + + (#e;Error error) + false)))] + + [(format "jvm " <domain> " and") bit;and] + [(format "jvm " <domain> " or") bit;or] + [(format "jvm " <domain> " xor") bit;xor] + )) + )))))] + + ["int" "jvm convert int-to-long" "jvm convert long-to-int"] + ["long" "lux noop" "lux noop"] ) (do-template [<domain> <post> <convert>] - [(context: (format "Bit-wise [" <domain> "]") + [(context: (format "Bit-wise [" <domain> "] { Shifters }") (<| (times +100) (do @ [param gen-nat subject gen-nat #let [shift (n.% +10 param)]] - (with-expansions [<combiners> (do-template [<procedure> <reference>] - [(test <procedure> - (|> (do meta;Monad<Meta> - [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (#ls;Nat subject)) - (<convert> (#ls;Nat param))))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (n.= (<reference> param subject) - (:! Nat valueG)) - - (#e;Error error) - false)))] - - [(format "jvm " <domain> " and") bit;and] - [(format "jvm " <domain> " or") bit;or] - [(format "jvm " <domain> " xor") bit;xor] - ) - <shifters> (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>] - [(test <procedure> - (|> (do meta;Monad<Meta> - [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (<pre> subject)) - (|> (#ls;Nat shift) - (list) - (#ls;Procedure "jvm convert long-to-int"))))))] - (@eval;eval sampleI)) - (meta;run (init-compiler [])) - (case> (#e;Success valueG) - (<test> (<reference> shift (<pre-subject> subject)) - (:! <type> valueG)) - - (#e;Error error) - false)))] - - [(format "jvm " <domain> " shl") bit;shift-left Nat n.= id #ls;Nat] - [(format "jvm " <domain> " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int #ls;Int)] - [(format "jvm " <domain> " ushr") bit;shift-right Nat n.= id #ls;Nat] - )] - ($_ seq - <combiners> - <shifters> - )))))] - - ["int" (|>. (list) (#ls;Procedure "jvm convert int-to-long")) (|>. (list) (#ls;Procedure "jvm convert long-to-int"))] - ["long" id id] + (`` ($_ seq + (~~ (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>] + [(test <procedure> + (|> (do meta;Monad<Meta> + [sampleI (@;generate (` (<post> ((~ (code;text <procedure>)) + (<convert> (~ (<pre> subject))) + ("jvm convert long-to-int" (~ (code;nat shift)))))))] + (@eval;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success valueG) + (<test> (<reference> shift (<pre-subject> subject)) + (:! <type> valueG)) + + (#e;Error error) + false)))] + + [(format "jvm " <domain> " shl") bit;shift-left Nat n.= id code;nat] + [(format "jvm " <domain> " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int code;int)] + [(format "jvm " <domain> " ushr") bit;shift-right Nat n.= id code;nat] + )) + )))))] + + ["int" "jvm convert int-to-long" "jvm convert long-to-int"] + ["long" "lux noop" "lux noop"] ) (do-template [<domain> <generator> <tag> <=> <<> <pre>] @@ -222,8 +231,9 @@ (with-expansions [<tests> (do-template [<procedure> <reference>] [(test <procedure> (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure <procedure> (list (<pre> (<tag> subject)) - (<pre> (<tag> param)))))] + [sampleI (@;generate (` ((~ (code;text <procedure>)) + (<pre> (~ (<tag> subject))) + (<pre> (~ (<tag> param))))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -240,14 +250,25 @@ <tests> )))))] - ["int" gen-int #ls;Int i.= i.< (|>. (list) (#ls;Procedure "jvm convert long-to-int"))] - ["long" gen-int #ls;Int i.= i.< id] - ["float" gen-frac #ls;Frac f.= f.< (|>. (list) (#ls;Procedure "jvm convert double-to-float"))] - ["double" gen-frac #ls;Frac f.= f.< id] - ["char" gen-int #ls;Int i.= i.< (|>. (list) (#ls;Procedure "jvm convert long-to-int") - (list) (#ls;Procedure "jvm convert int-to-char"))] + ["int" gen-int code;int i.= i.< "jvm convert long-to-int"] + ["long" gen-int code;int i.= i.< "lux noop"] + ["float" gen-frac code;frac f.= f.< "jvm convert double-to-float"] + ["double" gen-frac code;frac f.= f.< "lux noop"] + ["char" gen-int code;int i.= i.< "jvm convert long-to-char"] ) +(def: (jvm//array//new dimension class size) + (-> Nat Text Nat ls;Synthesis) + (` ("jvm array new" (~ (code;nat dimension)) (~ (code;text class)) (~ (code;nat size))))) + +(def: (jvm//array//write class idx inputS arrayS) + (-> Text Nat ls;Synthesis ls;Synthesis ls;Synthesis) + (` ("jvm array write" (~ (code;text class)) (~ (code;nat idx)) (~ inputS) (~ arrayS)))) + +(def: (jvm//array//read class idx arrayS) + (-> Text Nat ls;Synthesis ls;Synthesis) + (` ("jvm array read" (~ (code;text class)) (~ (code;nat idx)) (~ arrayS)))) + (context: "Array [Part 1]" (<| (times +100) (do @ @@ -264,10 +285,12 @@ (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>] [(test <class> (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size))) - (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write") - (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read") - <post>))] + [sampleI (@;generate (|> (jvm//array//new +0 <class> size) + (jvm//array//write <class> idx <input>) + (jvm//array//read <class> idx) + (~) + <post> + (`)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputZ) @@ -276,21 +299,20 @@ (#e;Error error) false)))] - ["boolean" Bool valueZ bool/= (#ls;Bool valueZ) id] - ["byte" Int valueB i.= (|> (#ls;Int valueB) - (list) (#ls;Procedure "jvm convert long-to-byte")) - (<| (#ls;Procedure "jvm convert byte-to-long") (list))] - ["short" Int valueS i.= (|> (#ls;Int valueS) - (list) (#ls;Procedure "jvm convert long-to-short")) - (<| (#ls;Procedure "jvm convert short-to-long") (list))] - ["int" Int valueI i.= (|> (#ls;Int valueI) - (list) (#ls;Procedure "jvm convert long-to-int")) - (<| (#ls;Procedure "jvm convert int-to-long") (list))] - ["long" Int valueL i.= (#ls;Int valueL) id] - ["float" Frac valueF f.= (|> (#ls;Frac valueF) - (list) (#ls;Procedure "jvm convert double-to-float")) - (<| (#ls;Procedure "jvm convert float-to-double") (list))] - ["double" Frac valueD f.= (#ls;Frac valueD) id] + ["boolean" Bool valueZ bool/= (code;bool valueZ) + "lux noop"] + ["byte" Int valueB i.= (|> (code;int valueB) (~) "jvm convert long-to-byte" (`)) + "jvm convert byte-to-long"] + ["short" Int valueS i.= (|> (code;int valueS) (~) "jvm convert long-to-short" (`)) + "jvm convert short-to-long"] + ["int" Int valueI i.= (|> (code;int valueI) (~) "jvm convert long-to-int" (`)) + "jvm convert int-to-long"] + ["long" Int valueL i.= (code;int valueL) + "lux noop"] + ["float" Frac valueF f.= (|> (code;frac valueF) (~) "jvm convert double-to-float" (`)) + "jvm convert float-to-double"] + ["double" Frac valueD f.= (code;frac valueD) + "lux noop"] )] ($_ seq <array> @@ -312,10 +334,12 @@ (with-expansions [<array> (do-template [<class> <type> <value> <test> <input> <post>] [(test <class> (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text <class>) (#ls;Nat size))) - (list (#ls;Text <class>) (#ls;Nat idx) <input>) (#ls;Procedure "jvm array write") - (list (#ls;Text <class>) (#ls;Nat idx)) (#ls;Procedure "jvm array read") - <post>))] + [sampleI (@;generate (|> (jvm//array//new +0 <class> size) + (jvm//array//write <class> idx <input>) + (jvm//array//read <class> idx) + (~) + <post> + (`)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -324,22 +348,25 @@ (#e;Error error) false)))] - ["char" Int valueC i.= (|> (#ls;Int valueC) - (list) (#ls;Procedure "jvm convert long-to-int") - (list) (#ls;Procedure "jvm convert int-to-char")) - (<| (#ls;Procedure "jvm convert char-to-long") (list))] - ["java.lang.Long" Int valueL i.= (#ls;Int valueL) id] + ["char" Int valueC i.= + (|> (code;int valueC) (~) "jvm convert long-to-int" "jvm convert int-to-char" (`)) + "jvm convert char-to-long"] + ["java.lang.Long" Int valueL i.= + (code;int valueL) + "lux noop"] )] ($_ seq <array> (test "java.lang.Double (level 1)" (|> (do meta;Monad<Meta> - [#let [inner (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Double") (#ls;Nat size))) - (list (#ls;Text "java.lang.Double") (#ls;Nat idx) (#ls;Frac valueD)) (#ls;Procedure "jvm array write"))] - sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +1) (#ls;Text "java.lang.Double") (#ls;Nat size))) - (list (#ls;Text "#Array") (#ls;Nat idx) inner) (#ls;Procedure "jvm array write") - (list (#ls;Text "#Array") (#ls;Nat idx)) (#ls;Procedure "jvm array read") - (list (#ls;Text "java.lang.Double") (#ls;Nat idx)) (#ls;Procedure "jvm array read")))] + [#let [inner (|> ("jvm array new" +0 "java.lang.Double" (~ (code;nat size))) + ("jvm array write" "java.lang.Double" (~ (code;nat idx)) (~ (code;frac valueD))) + (`))] + sampleI (@;generate (|> ("jvm array new" +1 "java.lang.Double" (~ (code;nat size))) + ("jvm array write" "#Array" (~ (code;nat idx)) (~ inner)) + ("jvm array read" "#Array" (~ (code;nat idx))) + ("jvm array read" "java.lang.Double" (~ (code;nat idx))) + (`)))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -349,8 +376,7 @@ false))) (test "jvm array length" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Procedure "jvm array new" (list (#ls;Nat +0) (#ls;Text "java.lang.Object") (#ls;Nat size))) - (list) (#ls;Procedure "jvm array length")))] + [sampleI (@;generate (` ("jvm array length" ("jvm array new" +0 "java.lang.Object" (~ (code;nat size))))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -370,10 +396,10 @@ (def: instances (List [Text (r;Random ls;Synthesis)]) - (let [gen-boolean (|> r;bool (:: r;Functor<Random> map (|>. #ls;Bool))) - gen-integer (|> r;int (:: r;Functor<Random> map (|>. #ls;Int))) - gen-double (|> r;frac (:: r;Functor<Random> map (|>. #ls;Frac))) - gen-string (|> (r;text +5) (:: r;Functor<Random> map (|>. #ls;Text)))] + (let [gen-boolean (|> r;bool (:: r;Functor<Random> map code;bool)) + gen-integer (|> r;int (:: r;Functor<Random> map code;int)) + gen-double (|> r;frac (:: r;Functor<Random> map code;frac)) + gen-string (|> (r;text +5) (:: r;Functor<Random> map code;text))] (list ["java.lang.Boolean" gen-boolean] ["java.lang.Long" gen-integer] ["java.lang.Double" gen-double] @@ -393,16 +419,14 @@ exception-message (r;text +5) #let [class (maybe;assume (list;nth class-idx classes)) [instance-class instance-gen] (maybe;assume (list;nth instance-idx instances)) - exception-message$ (|> (#ls;Text exception-message) - (list (#ls;Text "java.lang.String")) #ls;Tuple)] + exception-message$ (` ["java.lang.String" (~ (code;text exception-message))])] sample r;int monitor r;int instance instance-gen] ($_ seq (test "jvm object null" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Procedure "jvm object null" (list)) - (list) (#ls;Procedure "jvm object null?")))] + [sampleI (@;generate (` ("jvm object null?" ("jvm object null"))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -412,8 +436,7 @@ false))) (test "jvm object null?" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Int sample) - (list) (#ls;Procedure "jvm object null?")))] + [sampleI (@;generate (` ("jvm object null?" (~ (code;int sample)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -423,9 +446,7 @@ false))) (test "jvm object synchronized" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm object synchronized" - (list (#ls;Int monitor) - (#ls;Int sample))))] + [sampleI (@;generate (` ("jvm object synchronized" (~ (code;int monitor)) (~ (code;int sample)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -436,11 +457,10 @@ (test "jvm object throw" (|> (do meta;Monad<Meta> [_ @runtime;generate - sampleI (@;generate (|> (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.lang.Throwable") - exception-message$)) - (list) (#ls;Procedure "jvm object throw") - (#ls;Function +1 (list)) - (list) (#ls;Procedure "lux try")))] + sampleI (@;generate (` ("lux try" ("lux function" +1 [] + ("jvm object throw" ("jvm member invoke constructor" + "java.lang.Throwable" + (~ exception-message$)))))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -455,7 +475,7 @@ false))) (test "jvm object class" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm object class" (list (#ls;Text class))))] + [sampleI (@;generate (` ("jvm object class" (~ (code;text class)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -465,8 +485,7 @@ false))) (test "jvm object instance?" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm object instance?" (list (#ls;Text instance-class) - instance)))] + [sampleI (@;generate (` ("jvm object instance?" (~ (code;text instance-class)) (~ instance))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -485,28 +504,18 @@ [sample-short (|> r;int (:: @ map (|>. int/abs (i.% 100)))) sample-string (r;text +5) other-sample-string (r;text +5) - #let [shortS (|> (#ls;Int sample-short) - (list) (#ls;Procedure "jvm convert long-to-short") - (list (#ls;Text "short")) #ls;Tuple) - stringS (|> (#ls;Text sample-string) - (list (#ls;Text "java.lang.String")) #ls;Tuple) - type-codeS (|> (#ls;Procedure "jvm object null" (list)) - (list (#ls;Text "org.omg.CORBA.TypeCode")) #ls;Tuple) - idl-typeS (|> (#ls;Procedure "jvm object null" (list)) - (list (#ls;Text "org.omg.CORBA.IDLType")) #ls;Tuple) - value-member$ (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "org.omg.CORBA.ValueMember") - stringS - stringS - stringS - stringS - type-codeS - idl-typeS - shortS))]] + #let [shortS (` ["short" ("jvm convert long-to-short" (~ (code;int sample-short)))]) + stringS (` ["java.lang.String" (~ (code;text sample-string))]) + type-codeS (` ["org.omg.CORBA.TypeCode" ("jvm object null")]) + idl-typeS (` ["org.omg.CORBA.IDLType" ("jvm object null")]) + value-memberS (` ("jvm member invoke constructor" + "org.omg.CORBA.ValueMember" + (~ stringS) (~ stringS) (~ stringS) (~ stringS) + (~ type-codeS) (~ idl-typeS) (~ shortS)))]] ($_ seq (test "jvm member static get" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> (#ls;Procedure "jvm member static get" (list (#ls;Text "java.util.GregorianCalendar") (#ls;Text "AD") (#ls;Text "int"))) - (list) (#ls;Procedure "jvm convert int-to-long")))] + [sampleI (@;generate (` ("jvm convert int-to-long" ("jvm member static get" "java.util.GregorianCalendar" "AD" "int"))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -516,8 +525,8 @@ false))) (test "jvm member static put" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm member static put" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor") - (#ls;Procedure "jvm member static get" (list (#ls;Text "java.awt.datatransfer.DataFlavor") (#ls;Text "allHtmlFlavor") (#ls;Text "java.awt.datatransfer.DataFlavor"))))))] + [sampleI (@;generate (` ("jvm member static put" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor" + ("jvm member static get" "java.awt.datatransfer.DataFlavor" "allHtmlFlavor" "java.awt.datatransfer.DataFlavor"))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -527,11 +536,7 @@ false))) (test "jvm member virtual get" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> value-member$ - (list (#ls;Text "org.omg.CORBA.ValueMember") - (#ls;Text "name") - (#ls;Text "java.lang.String")) - (#ls;Procedure "jvm member virtual get")))] + [sampleI (@;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String" (~ value-memberS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -541,16 +546,9 @@ false))) (test "jvm member virtual put" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> value-member$ - (list (#ls;Text "org.omg.CORBA.ValueMember") - (#ls;Text "name") - (#ls;Text "java.lang.String") - (#ls;Text other-sample-string)) - (#ls;Procedure "jvm member virtual put") - (list (#ls;Text "org.omg.CORBA.ValueMember") - (#ls;Text "name") - (#ls;Text "java.lang.String")) - (#ls;Procedure "jvm member virtual get")))] + [sampleI (@;generate (` ("jvm member virtual get" "org.omg.CORBA.ValueMember" "name" "java.lang.String" + ("jvm member virtual put" "org.omg.CORBA.ValueMember" "name" "java.lang.String" + (~ (code;text other-sample-string)) (~ value-memberS)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -568,22 +566,14 @@ (<| (times +100) (do @ [sample (|> r;int (:: @ map (|>. int/abs (i.% 100)))) - #let [object-longS (|> (#ls;Int sample) - (list (#ls;Text "java.lang.Object")) #ls;Tuple) - intS (|> (#ls;Int sample) - (list) (#ls;Procedure "jvm convert long-to-int") - (list (#ls;Text "int")) #ls;Tuple) - coded-intS (|> (#ls;Text (int/encode sample)) - (list (#ls;Text "java.lang.String")) #ls;Tuple) - array-listS (#ls;Procedure "jvm member invoke constructor" (list (#ls;Text "java.util.ArrayList") intS))]] + #let [object-longS (` ["java.lang.Object" (~ (code;int sample))]) + intS (` ["int" ("jvm convert long-to-int" (~ (code;int sample)))]) + coded-intS (` ["java.lang.String" (~ (code;text (int/encode sample)))]) + array-listS (` ("jvm member invoke constructor" "java.util.ArrayList" (~ intS)))]] ($_ seq (test "jvm member invoke static" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm member invoke static" - (list (#ls;Text "java.lang.Long") - (#ls;Text "decode") - (#ls;Text "java.lang.Long") - coded-intS)))] + [sampleI (@;generate (` ("jvm member invoke static" "java.lang.Long" "decode" "java.lang.Long" (~ coded-intS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -593,12 +583,8 @@ false))) (test "jvm member invoke virtual" (|> (do meta;Monad<Meta> - [sampleI (@;generate (|> object-longS - (list (#ls;Text "java.lang.Object") - (#ls;Text "equals") - (#ls;Text "boolean") - (#ls;Int sample)) - (#ls;Procedure "jvm member invoke virtual")))] + [sampleI (@;generate (` ("jvm member invoke virtual" "java.lang.Object" "equals" "boolean" + (~ (code;int sample)) (~ object-longS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) @@ -608,12 +594,8 @@ false))) (test "jvm member invoke interface" (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Procedure "jvm member invoke interface" - (list (#ls;Text "java.util.Collection") - (#ls;Text "add") - (#ls;Text "boolean") - array-listS - object-longS)))] + [sampleI (@;generate (` ("jvm member invoke interface" "java.util.Collection" "add" "boolean" + (~ array-listS) (~ object-longS))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) diff --git a/new-luxc/test/test/luxc/generator/reference.lux b/new-luxc/test/test/luxc/generator/reference.lux index 32f9c1b80..0e6f9ada5 100644 --- a/new-luxc/test/test/luxc/generator/reference.lux +++ b/new-luxc/test/test/luxc/generator/reference.lux @@ -6,6 +6,7 @@ (data ["e" error]) ["r" math/random] [meta] + (meta [code]) test) (luxc (lang ["ls" synthesis]) ["_;" module] @@ -46,7 +47,7 @@ (|> (do meta;Monad<Meta> [_ (_module;with-module +0 module-name (statementG;generate-def def-name Int valueI empty-metaI (' {}))) - sampleI (exprG;generate (#ls;Definition [module-name def-name]))] + sampleI (exprG;generate (code;symbol [module-name def-name]))] (evalG;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -66,8 +67,8 @@ (|> (do meta;Monad<Meta> [sampleI (caseG;generate-let exprG;generate register - (#ls;Int value) - (#ls;Variable (nat-to-int register)))] + (code;int value) + (` ((~ (code;int (nat-to-int register))))))] (evalG;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 7a14788b7..3157d85d9 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -11,7 +11,8 @@ (coll [array] [list])) ["r" math/random "r/" Monad<Random>] - [meta #+ Monad<Meta>] + [meta] + (meta [code]) [host] test) (luxc [";L" host] @@ -28,34 +29,34 @@ (def: gen-primitive (r;Random ls;Synthesis) - (r;either (r;either (r;either (r/wrap #ls;Unit) - (r/map (|>. #ls;Bool) r;bool)) - (r;either (r/map (|>. #ls;Nat) r;nat) - (r/map (|>. #ls;Int) r;int))) - (r;either (r;either (r/map (|>. #ls;Deg) r;deg) - (r/map (|>. #ls;Frac) r;frac)) - (r/map (|>. #ls;Text) (r;text +5))))) + (r;either (r;either (r;either (r/wrap (' [])) + (r/map code;bool r;bool)) + (r;either (r/map code;nat r;nat) + (r/map code;int r;int))) + (r;either (r;either (r/map code;deg r;deg) + (r/map code;frac r;frac)) + (r/map code;text (r;text +5))))) (def: (corresponds? [prediction sample]) (-> [ls;Synthesis Top] Bool) (case prediction - #ls;Unit + [_ (#;Tuple #;Nil)] (is hostL;unit (:! Text sample)) (^template [<tag> <type> <test>] - (<tag> prediction') + [_ (<tag> prediction')] (case (host;try (<test> prediction' (:! <type> sample))) (#e;Success result) result (#e;Error error) false)) - ([#ls;Bool Bool bool/=] - [#ls;Nat Nat n.=] - [#ls;Int Int i.=] - [#ls;Deg Deg d.=] - [#ls;Frac Frac f.=] - [#ls;Text Text text/=]) + ([#;Bool Bool bool/=] + [#;Nat Nat n.=] + [#;Int Int i.=] + [#;Deg Deg d.=] + [#;Frac Frac f.=] + [#;Text Text text/=]) _ false @@ -68,7 +69,7 @@ members (r;list size gen-primitive)] (test "Can generate tuple." (|> (do meta;Monad<Meta> - [sampleI (@;generate (#ls;Tuple members))] + [sampleI (@;generate (code;tuple members))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -87,9 +88,9 @@ #let [last? (n.= (n.dec num-tags) tag)] member gen-primitive] (test "Can generate variant." - (|> (do Monad<Meta> + (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Variant tag last? member))] + sampleI (@;generate (` ((~ (code;nat tag)) (~ (code;bool last?)) (~ member))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) diff --git a/new-luxc/test/test/luxc/synthesizer/case/special.lux b/new-luxc/test/test/luxc/synthesizer/case/special.lux index b369eb532..63a921b68 100644 --- a/new-luxc/test/test/luxc/synthesizer/case/special.lux +++ b/new-luxc/test/test/luxc/synthesizer/case/special.lux @@ -39,7 +39,7 @@ outputA]))]] (test "Can detect and reify simple 'let' expressions." (|> (synthesizer;synthesize letA) - (case> (#ls;Let registerS inputS outputS) + (case> (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat registerS)] inputS outputS))]) (and (n.= registerA registerS) (corresponds? inputA inputS) (corresponds? outputA outputS)) @@ -63,7 +63,7 @@ [(#la;BoolP true) thenA])))]] (test "Can detect and reify simple 'if' expressions." (|> (synthesizer;synthesize ifA) - (case> (#ls;If inputS thenS elseS) + (case> (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) (and (corresponds? inputA inputS) (corresponds? thenA thenS) (corresponds? elseA elseS)) diff --git a/new-luxc/test/test/luxc/synthesizer/common.lux b/new-luxc/test/test/luxc/synthesizer/common.lux index 10b1a88b2..35e7a71ba 100644 --- a/new-luxc/test/test/luxc/synthesizer/common.lux +++ b/new-luxc/test/test/luxc/synthesizer/common.lux @@ -1,7 +1,7 @@ (;module: lux - (lux (data [bool "B/" Eq<Bool>] - [text "T/" Eq<Text>]) + (lux (data [bool "bool/" Eq<Bool>] + [text "text/" Eq<Text>]) ["r" math/random "r/" Monad<Random>]) (luxc (lang ["la" analysis] ["ls" synthesis]))) @@ -19,16 +19,18 @@ (def: #export (corresponds? analysis synthesis) (-> la;Analysis ls;Synthesis Bool) (case [analysis synthesis] + [#la;Unit [_ (#;Tuple #;Nil)]] + true + (^template [<analysis> <synthesis> <test>] - [(<analysis> valueA) (<synthesis> valueS)] + [(<analysis> valueA) [_ (<synthesis> valueS)]] (<test> valueA valueS)) - ([#la;Unit #ls;Unit is] - [#la;Bool #ls;Bool B/=] - [#la;Nat #ls;Nat n.=] - [#la;Int #ls;Int i.=] - [#la;Deg #ls;Deg d.=] - [#la;Frac #ls;Frac f.=] - [#la;Text #ls;Text T/=]) + ([#la;Bool #;Bool bool/=] + [#la;Nat #;Nat n.=] + [#la;Int #;Int i.=] + [#la;Deg #;Deg d.=] + [#la;Frac #;Frac f.=] + [#la;Text #;Text text/=]) _ false)) diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux index 40aef8c3b..f38a2fab5 100644 --- a/new-luxc/test/test/luxc/synthesizer/function.lux +++ b/new-luxc/test/test/luxc/synthesizer/function.lux @@ -114,7 +114,7 @@ ($_ seq (test "Nested functions will get folded together." (|> (synthesizer;synthesize function1) - (case> (#ls;Function args captured output) + (case> (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat args)] [_ (#;Tuple captured)] output))]) (and (n.= args1 args) (corresponds? prediction1 output)) @@ -122,7 +122,8 @@ (n.= +0 args1)))) (test "Folded functions provide direct access to captured variables." (|> (synthesizer;synthesize function2) - (case> (#ls;Function args captured (#ls;Variable output)) + (case> (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat args)] [_ (#;Tuple captured)] + [_ (#;Form (list [_ (#;Int output)]))]))]) (and (n.= args2 args) (i.= prediction2 output)) @@ -130,7 +131,8 @@ false))) (test "Folded functions properly offset local variables." (|> (synthesizer;synthesize function3) - (case> (#ls;Function args captured (#ls;Variable output)) + (case> (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat args)] [_ (#;Tuple captured)] + [_ (#;Form (list [_ (#;Int output)]))]))]) (and (n.= args3 args) (i.= prediction3 output)) @@ -147,7 +149,7 @@ ($_ seq (test "Can synthesize function application." (|> (synthesizer;synthesize (la;apply argsA funcA)) - (case> (#ls;Call argsS funcS) + (case> (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) (and (corresponds? funcA funcS) (list;every? (product;uncurry corresponds?) (list;zip2 argsA argsS))) diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux index 9b048242d..165408fb6 100644 --- a/new-luxc/test/test/luxc/synthesizer/loop.lux +++ b/new-luxc/test/test/luxc/synthesizer/loop.lux @@ -2,9 +2,9 @@ lux (lux [io] (control [monad #+ do]) - (data [bool "B/" Eq<Bool>] + (data [bool "bool/" Eq<Bool>] [number] - (coll [list "L/" Functor<List> Fold<List>] + (coll [list "list/" Functor<List> Fold<List>] ["s" set]) text/format) ["r" math/random "r/" Monad<Random>] @@ -19,29 +19,29 @@ (-> ls;Arity ls;Synthesis Bool) (loop [exprS exprS] (case exprS - (#ls;Case inputS pathS) + (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) (loop [pathS pathS] (case pathS - (#ls;AltP leftS rightS) + (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftS rightS))]) (or (recur leftS) (recur rightS)) - (#ls;SeqP leftS rightS) + (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftS rightS))]) (recur rightS) - - (#ls;ExecP bodyS) + + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (does-recursion? arity bodyS) _ false)) - (#ls;Recur argsS) + (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) (n.= arity (list;size argsS)) - (#ls;Let register inputS bodyS) + (^ [_ (#;Form (list [_ (#;Text "lux let")] register inputS bodyS))]) (recur bodyS) - (#ls;If inputS thenS elseS) + (^ [_ (#;Form (list [_ (#;Text "lux if")] inputS thenS elseS))]) (or (recur thenS) (recur elseS)) @@ -56,14 +56,14 @@ [inputA (|> r;nat (:: @ map (|>. #la;Nat))) num-cases (|> r;nat (:: @ map (|>. (n.% +10) (n.max +1)))) tests (|> (r;set number;Hash<Nat> num-cases r;nat) - (:: @ map (|>. s;to-list (L/map (|>. #la;NatP))))) + (:: @ map (|>. s;to-list (list/map (|>. #la;NatP))))) #let [bad-bodies (list;repeat num-cases #la;Unit)] good-body (gen-body arity output) where-to-set (|> r;nat (:: @ map (n.% num-cases))) #let [bodies (list;concat (list (list;take where-to-set bad-bodies) (list good-body) (list;drop (n.inc where-to-set) bad-bodies)))]] - (wrap (#ls;Case inputA + (wrap (#la;Case inputA (list;zip2 tests bodies))))) (r;either (do r;Monad<Random> [valueS r;bool @@ -73,8 +73,8 @@ [valueS r;bool then|else r;bool output' (gen-body arity output) - #let [thenA (if then|else output' #ls;Unit) - elseA (if (not then|else) output' #ls;Unit)]] + #let [thenA (if then|else output' #la;Unit) + elseA (if (not then|else) output' #la;Unit)]] (wrap (#la;Case (#la;Bool valueS) (list [(#la;BoolP then|else) thenA] [(#la;BoolP (not then|else)) elseA]))))) @@ -82,10 +82,10 @@ (def: (make-apply func args) (-> la;Analysis (List la;Analysis) la;Analysis) - (L/fold (function [arg' func'] - (#la;Apply arg' func')) - func - args)) + (list/fold (function [arg' func'] + (#la;Apply arg' func')) + func + args)) (def: (make-function arity body) (-> ls;Arity la;Analysis la;Analysis) @@ -141,10 +141,10 @@ ($_ seq (test "Can accurately identify (and then reify) tail recursion." (case (synthesizer;synthesize analysis) - (#ls;Function _arity _env _body) + (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _body))]) (|> _body (does-recursion? arity) - (B/= prediction) + (bool/= prediction) (and (n.= arity _arity))) _ @@ -157,11 +157,13 @@ ($_ seq (test "Can reify loops." (case (synthesizer;synthesize (make-apply analysis (list;repeat arity #la;Unit))) - (#ls;Loop _register _inits _body) + (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat in_register)] [_ (#;Tuple _inits)] _body))]) (and (n.= arity (list;size _inits)) (not (&&loop;contains-self-reference? _body))) - (#ls;Call argsS (#ls;Function _arity _env _bodyS)) + (^ [_ (#;Form (list& [_ (#;Text "lux call")] + [_ (#;Form (list [_ (#;Text "lux function")] _arity _env _bodyS))] + argsS))]) (&&loop;contains-self-reference? _bodyS) _ diff --git a/new-luxc/test/test/luxc/synthesizer/primitive.lux b/new-luxc/test/test/luxc/synthesizer/primitive.lux index a7fb6913e..e8484697d 100644 --- a/new-luxc/test/test/luxc/synthesizer/primitive.lux +++ b/new-luxc/test/test/luxc/synthesizer/primitive.lux @@ -20,22 +20,26 @@ %deg% r;deg %frac% r;frac %text% (r;text +5)] - (with-expansions - [<tests> (do-template [<desc> <analysis> <synthesis> <sample>] - [(test (format "Can synthesize " <desc> ".") - (|> (synthesizer;synthesize (<analysis> <sample>)) - (case> (<synthesis> value) - (is <sample> value) + (`` ($_ seq + (test (format "Can synthesize unit.") + (|> (synthesizer;synthesize (#la;Unit [])) + (case> [_ (#;Tuple #;Nil)] + true - _ - false)))] + _ + false))) + (~~ (do-template [<desc> <analysis> <synthesis> <sample>] + [(test (format "Can synthesize " <desc> ".") + (|> (synthesizer;synthesize (<analysis> <sample>)) + (case> [_ (<synthesis> value)] + (is <sample> value) - ["unit" #la;Unit #ls;Unit []] - ["bool" #la;Bool #ls;Bool %bool%] - ["nat" #la;Nat #ls;Nat %nat%] - ["int" #la;Int #ls;Int %int%] - ["deg" #la;Deg #ls;Deg %deg%] - ["frac" #la;Frac #ls;Frac %frac%] - ["text" #la;Text #ls;Text %text%])] - ($_ seq - <tests>))))) + _ + false)))] + + ["bool" #la;Bool #;Bool %bool%] + ["nat" #la;Nat #;Nat %nat%] + ["int" #la;Int #;Int %int%] + ["deg" #la;Deg #;Deg %deg%] + ["frac" #la;Frac #;Frac %frac%] + ["text" #la;Text #;Text %text%]))))))) diff --git a/new-luxc/test/test/luxc/synthesizer/procedure.lux b/new-luxc/test/test/luxc/synthesizer/procedure.lux index 54f1b1f27..1753dcc47 100644 --- a/new-luxc/test/test/luxc/synthesizer/procedure.lux +++ b/new-luxc/test/test/luxc/synthesizer/procedure.lux @@ -24,8 +24,8 @@ ($_ seq (test "Can synthesize procedure calls." (|> (synthesizer;synthesize (#la;Procedure nameA argsA)) - (case> (#ls;Procedure nameS argsS) - (and (T/= nameA nameS) + (case> (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (and (T/= nameA procedure) (list;every? (product;uncurry corresponds?) (list;zip2 argsA argsS))) diff --git a/new-luxc/test/test/luxc/synthesizer/structure.lux b/new-luxc/test/test/luxc/synthesizer/structure.lux index 441f422bb..517f087d1 100644 --- a/new-luxc/test/test/luxc/synthesizer/structure.lux +++ b/new-luxc/test/test/luxc/synthesizer/structure.lux @@ -22,7 +22,7 @@ ($_ seq (test "Can synthesize variants." (|> (synthesizer;synthesize (la;sum tagA size +0 memberA)) - (case> (#ls;Variant tagS last?S memberS) + (case> (^ [_ (#;Form (list [_ (#;Nat tagS)] [_ (#;Bool last?S)] memberS))]) (and (n.= tagA tagS) (B/= (n.= (n.dec size) tagA) last?S) @@ -40,7 +40,7 @@ ($_ seq (test "Can synthesize tuple." (|> (synthesizer;synthesize (la;product membersA)) - (case> (#ls;Tuple membersS) + (case> [_ (#;Tuple membersS)] (and (n.= size (list;size membersS)) (list;every? (product;uncurry corresponds?) (list;zip2 membersA membersS))) |