From cab9451961fa25fd6683c1c7bd836941bd84e48b Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 6 Nov 2017 18:34:51 -0400
Subject: - Fixed some bugs.
---
new-luxc/source/luxc/lang/synthesis/case.lux | 25 ++++++++++-----
new-luxc/source/luxc/lang/synthesis/expression.lux | 8 ++---
new-luxc/source/luxc/lang/translation.lux | 37 +++++++++++-----------
new-luxc/source/luxc/lang/translation/case.jvm.lux | 3 +-
.../source/luxc/lang/translation/common.jvm.lux | 36 ++-------------------
.../source/luxc/lang/translation/function.jvm.lux | 15 +++++----
.../source/luxc/lang/translation/reference.jvm.lux | 8 +++--
7 files changed, 56 insertions(+), 76 deletions(-)
(limited to 'new-luxc/source/luxc/lang')
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
- [[_ 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
+ [[_ 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
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 Monoid]))
[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
[@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
- [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])
(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
- [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)))))
--
cgit v1.2.3