diff options
| -rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 55 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/case.lux | 25 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/expression.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation.lux | 37 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/case.jvm.lux | 3 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/common.jvm.lux | 36 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/function.jvm.lux | 15 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/reference.jvm.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/scope.lux | 57 |
9 files changed, 144 insertions, 100 deletions
diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index 2cbdf5883..b2bf07d32 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control [monad #+ do]) + (lux (control [monad #+ do] + pipe) (concurrency ["A" atom]) (data ["e" error] [text] @@ -83,8 +84,56 @@ (A;atom (dict;new text;Hash<Text>)))] {#commonT;loader (memory-class-loader store) #commonT;store store - #commonT;function-class #;None - #commonT;artifacts (dict;new text;Hash<Text>)}))) + #commonT;artifacts (dict;new text;Hash<Text>) + #commonT;context ["" +0]}))) + +(def: #export (with-context name expr) + (All [a] (-> Text (Meta a) (Meta a))) + (;function [compiler] + (let [old (:! commonT;Host (get@ #;host compiler))] + (case (expr (set@ #;host + (:! Void (set@ #commonT;context [name +0] old)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! commonT;Host) + (set@ #commonT;context (get@ #commonT;context old)) + (:! Void)) + compiler') + output]) + + (#e;Error error) + (#e;Error error))))) + +(def: #export (with-sub-context expr) + (All [a] (-> (Meta a) (Meta [Text a]))) + (;function [compiler] + (let [old (:! commonT;Host (get@ #;host compiler)) + [old-name old-sub] (get@ #commonT;context old) + new-name (format old-name "/" (%n old-sub))] + (case (expr (set@ #;host + (:! Void (set@ #commonT;context [new-name +0] old)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! commonT;Host) + (set@ #commonT;context [old-name (n.inc old-sub)]) + (:! Void)) + compiler') + [new-name output]]) + + (#e;Error error) + (#e;Error error))))) + +(def: #export context + (Meta Text) + (;function [compiler] + (#e;Success [compiler + (|> (get@ #;host compiler) + (:! commonT;Host) + (get@ #commonT;context) + (let> [name sub] + name))]))) (def: #export class-loader (Meta ClassLoader) diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index e66bbf3a8..8bc1e43f9 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -9,8 +9,8 @@ (luxc (lang ["la" analysis] ["ls" synthesis]))) -(def: #export (path pattern) - (-> la;Pattern ls;Path) +(def: #export (path outer-arity pattern) + (-> ls;Arity la;Pattern ls;Path) (case pattern (^code ("lux case tuple" [(~@ membersP)])) (case (list;reverse membersP) @@ -18,7 +18,7 @@ (' ("lux case pop")) (#;Cons singletonP #;Nil) - (path singletonP) + (path outer-arity singletonP) (#;Cons lastP prevsP) (let [length (list;size membersP) @@ -26,10 +26,10 @@ [_ 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))) + ("lux case tuple left" (~ (code;nat current-idx)) (~ (path outer-arity current-pattern))) (~ next-path)))]) [(n.dec last-idx) - (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))] + (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path outer-arity lastP))))] prevsP)] (` ("lux case seq" (~ tuple-path) @@ -38,12 +38,21 @@ (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) (` ("lux case seq" (~ (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)))))) + (` ("lux case variant right" (~ (code;nat tag)) (~ (path outer-arity memberP)))) + (` ("lux case variant left" (~ (code;nat tag)) (~ (path outer-arity memberP)))))) + ("lux case pop"))) + + (^code ("lux case bind" (~ [_ (#;Nat register)]))) + (` ("lux case seq" + ("lux case bind" (~ (if (n.> +1 outer-arity) + (code;nat (n.+ (n.dec outer-arity) register)) + (code;nat register)))) ("lux case pop"))) _ - pattern)) + (` ("lux case seq" + (~ pattern) + ("lux case pop"))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index 531606ba7..9ea397576 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -60,9 +60,9 @@ (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis) (` ("lux call" (~ funcS) (~@ argsS)))) -(def: (synthesize-case synthesize inputA branchesA) +(def: (synthesize-case synthesize outer-arity inputA branchesA) (-> (-> la;Analysis ls;Synthesis) - la;Analysis (List [la;Pattern la;Analysis]) + ls;Arity la;Analysis (List [la;Pattern la;Analysis]) ls;Synthesis) (let [inputS (synthesize inputA)] (case (list;reverse branchesA) @@ -84,7 +84,7 @@ (function [pattern expr] (|> (synthesize expr) (~) ("lux case exec") - ("lux case seq" (~ (caseS;path pattern))) + ("lux case seq" (~ (caseS;path outer-arity pattern))) (`)))) pathS (list/fold caseS;weave (transform-branch lastP lastA) @@ -143,7 +143,7 @@ (var$ (maybe;default var (dict;get var resolver)))) (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) - (synthesize-case (recur outer-arity resolver num-locals) inputA branchesA) + (synthesize-case (recur outer-arity resolver num-locals) outer-arity inputA branchesA) (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) [(s;run scope (p;some s;int)) (#e;Success raw-env)]) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 60fbde6c8..779cb92fd 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -38,24 +38,25 @@ (-> Code (Meta Unit)) (case code (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ metaC))) - (do meta;Monad<Meta> - [[_ metaA] (&;with-scope - (&;with-expected-type Code - (analyse metaC))) - metaI (expressionT;translate (expressionS;synthesize metaA)) - metaV (evalT;eval metaI) - [_ valueT valueA] (&;with-scope - (if (meta;type? (:! Code metaV)) - (&;with-expected-type Type - (do @ - [valueA (analyse valueC)] - (wrap [Type valueA]))) - (commonA;with-unknown-type - (analyse valueC)))) - valueI (expressionT;translate (expressionS;synthesize valueA)) - _ (&;with-scope - (statementT;translate-def def-name valueT valueI metaI (:! Code metaV)))] - (wrap [])) + (hostL;with-context def-name + (do meta;Monad<Meta> + [[_ metaA] (&;with-scope + (&;with-expected-type Code + (analyse metaC))) + metaI (expressionT;translate (expressionS;synthesize metaA)) + metaV (evalT;eval metaI) + [_ valueT valueA] (&;with-scope + (if (meta;type? (:! Code metaV)) + (&;with-expected-type Type + (do @ + [valueA (analyse valueC)] + (wrap [Type valueA]))) + (commonA;with-unknown-type + (analyse valueC)))) + valueI (expressionT;translate (expressionS;synthesize valueA)) + _ (&;with-scope + (statementT;translate-def def-name valueT valueI metaI (:! Code metaV)))] + (wrap []))) (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC))) (do meta;Monad<Meta> diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index 3858627ff..09ffae328 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -70,8 +70,7 @@ (^ [_ (#;Form (list [_ (#;Text "lux case bind")] [_ (#;Nat register)]))]) (meta/wrap (|>. peekI - ($i;ASTORE register) - popI)) + ($i;ASTORE register))) [_ (#;Bool value)] (meta/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux index 1870530c2..f9825614a 100644 --- a/new-luxc/source/luxc/lang/translation/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/common.jvm.lux @@ -33,8 +33,8 @@ (type: #export Host {#loader ClassLoader #store Class-Store - #function-class (Maybe Text) - #artifacts Artifacts}) + #artifacts Artifacts + #context [Text Nat]}) (exception: Unknown-Class) (exception: Class-Already-Stored) @@ -93,38 +93,6 @@ (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) (ex;throw Unknown-Class name))))) -(def: #export (with-function class expr) - (All [a] (-> Text (Meta a) (Meta a))) - (;function [compiler] - (let [host (:! Host (get@ #;host compiler)) - old-function-class (get@ #function-class host)] - (case (expr (set@ #;host - (:! Void (set@ #function-class - (#;Some class) - host)) - compiler)) - (#e;Success [compiler' output]) - (#e;Success [(update@ #;host - (|>. (:! Host) - (set@ #function-class old-function-class) - (:! Void)) - compiler') - output]) - - (#e;Error error) - (#e;Error error))))) - -(def: #export function - (Meta Text) - (;function [compiler] - (let [host (:! Host (get@ #;host compiler))] - (case (get@ #function-class host) - #;None - (ex;throw No-Function-Being-Compiled "") - - (#;Some function-class) - (#e;Success [compiler function-class]))))) - (def: #export bytecode-version Int Opcodes.V1_6) (def: #export value-field Text "_value") diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index ebdb28853..1b7f6267b 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -1,7 +1,8 @@ (;module: lux (lux (control [monad #+ do]) - (data text/format + (data [text] + text/format (coll [list "list/" Functor<List> Monoid<List>])) [meta]) (luxc ["&" base] @@ -266,13 +267,11 @@ $i;ARETURN )))) -(def: #export (with-function translate class env arity body) - (-> (-> ls;Synthesis (Meta $;Inst)) - Text (List Variable) ls;Arity ls;Synthesis +(def: #export (with-function class env arity bodyI) + (-> Text (List Variable) ls;Arity $;Inst (Meta [$;Def $;Inst])) (do meta;Monad<Meta> [@begin $i;make-label - bodyI (commonT;with-function class (translate body)) #let [env-size (list;size env) applyD (: $;Def (if (poly-arg? arity) @@ -300,8 +299,10 @@ (List Variable) ls;Arity ls;Synthesis (Meta $;Inst)) (do meta;Monad<Meta> - [function-class (:: @ map %code (meta;gensym "function")) - [functionD instanceI] (with-function translate function-class env arity body) + [[context bodyI] (hostL;with-sub-context + (translate body)) + #let [function-class (text;replace-all "/+" "$" context)] + [functionD instanceI] (with-function function-class env arity bodyI) _ (commonT;store-class function-class ($d;class #$;V1.6 #$;Public $;finalC function-class (list) diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux index da86dd5b9..57336f27c 100644 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -1,9 +1,11 @@ (;module: lux (lux (control [monad #+ do]) - (data text/format) + (data [text] + text/format) [meta "meta/" Monad<Meta>]) (luxc ["&" base] + [";L" host] (host ["$" jvm] (jvm ["$t" type] ["$i" inst])) @@ -15,9 +17,9 @@ (def: #export (translate-captured variable) (-> Variable (Meta $;Inst)) (do meta;Monad<Meta> - [function-class commonT;function] + [function-class hostL;context] (wrap (|>. ($i;ALOAD +0) - ($i;GETFIELD function-class + ($i;GETFIELD (text;replace-all "/+" "$" function-class) (|> variable i.inc (i.* -1) int-to-nat functionT;captured) commonT;$Object))))) diff --git a/new-luxc/source/luxc/scope.lux b/new-luxc/source/luxc/scope.lux index 4ce8a51cb..165399c8f 100644 --- a/new-luxc/source/luxc/scope.lux +++ b/new-luxc/source/luxc/scope.lux @@ -1,36 +1,51 @@ (;module: lux (lux (control monad) - (data [text] + (data [text "text/" Eq<Text>] text/format [maybe "maybe/" Monad<Maybe>] [product] ["e" error] - (coll [list "list/" Fold<List> Monoid<List>])) + (coll [list "list/" Functor<List> Fold<List> Monoid<List>])) [meta]) - (luxc ["&" base])) + (luxc ["&" base] + (lang [";L" variable #+ Variable]))) (type: Locals (Bindings Text [Type Nat])) (type: Captured (Bindings Text [Type Ref])) -(do-template [<slot> <is> <get> <then>] - [(def: (<is> name scope) - (-> Text Scope Bool) - (|> scope - (get@ [<slot> #;mappings]) - (&;pl-contains? name))) - - (def: (<get> name scope) - (-> Text Scope (Maybe [Type Ref])) - (|> scope - (get@ [<slot> #;mappings]) - (&;pl-get name) - (maybe/map (function [[type value]] - [type (<then> value)]))))] - - [#;locals is-local? get-local #;Local] - [#;captured is-captured? get-captured id] - ) +(def: (is-local? name scope) + (-> Text Scope Bool) + (|> scope + (get@ [#;locals #;mappings]) + (&;pl-contains? name))) + +(def: (get-local name scope) + (-> Text Scope (Maybe [Type Ref])) + (|> scope + (get@ [#;locals #;mappings]) + (&;pl-get name) + (maybe/map (function [[type value]] + [type (#;Local value)])))) + +(def: (is-captured? name scope) + (-> Text Scope Bool) + (|> scope + (get@ [#;captured #;mappings]) + (&;pl-contains? name))) + +(def: (get-captured name scope) + (-> Text Scope (Maybe [Type Ref])) + (loop [idx +0 + mappings (get@ [#;captured #;mappings] scope)] + (case mappings + #;Nil + #;None + + (#;Cons [_name [_source-type _source-ref]] mappings') + (if (text/= name _name) + (#;Some [_source-type (#;Captured idx)]) + (recur (n.inc idx) mappings'))))) (def: (is-ref? name scope) (-> Text Scope Bool) |