aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/host.jvm.lux55
-rw-r--r--new-luxc/source/luxc/lang/synthesis/case.lux25
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux8
-rw-r--r--new-luxc/source/luxc/lang/translation.lux37
-rw-r--r--new-luxc/source/luxc/lang/translation/case.jvm.lux3
-rw-r--r--new-luxc/source/luxc/lang/translation/common.jvm.lux36
-rw-r--r--new-luxc/source/luxc/lang/translation/function.jvm.lux15
-rw-r--r--new-luxc/source/luxc/lang/translation/reference.jvm.lux8
-rw-r--r--new-luxc/source/luxc/scope.lux57
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)