aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
authorEduardo Julian2017-10-31 22:26:13 -0400
committerEduardo Julian2017-10-31 22:26:13 -0400
commit19c589edc2c1dd77550e26d4f5cf78ec772da337 (patch)
treed070c773c7bd5cec8d33caa1841fbe0e342ec563 /new-luxc/source
parent6c753288a89eadb3f7d70a8844e466c48c809051 (diff)
- Migrated the format of analysis nodes from a custom data-type, to just Code nodes.
Diffstat (limited to 'new-luxc/source')
-rw-r--r--new-luxc/source/luxc/analyser.lux2
-rw-r--r--new-luxc/source/luxc/analyser/case.lux39
-rw-r--r--new-luxc/source/luxc/analyser/case/coverage.lux82
-rw-r--r--new-luxc/source/luxc/analyser/function.lux16
-rw-r--r--new-luxc/source/luxc/analyser/primitive.lux27
-rw-r--r--new-luxc/source/luxc/analyser/procedure/common.lux17
-rw-r--r--new-luxc/source/luxc/analyser/procedure/host.jvm.lux58
-rw-r--r--new-luxc/source/luxc/analyser/reference.lux10
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux2
-rw-r--r--new-luxc/source/luxc/generator/expression.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/function.jvm.lux26
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux1
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux1
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux7
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux120
-rw-r--r--new-luxc/source/luxc/lang/synthesis.lux2
-rw-r--r--new-luxc/source/luxc/lang/variable.lux47
-rw-r--r--new-luxc/source/luxc/synthesizer.lux145
-rw-r--r--new-luxc/source/luxc/synthesizer/case.lux27
-rw-r--r--new-luxc/source/luxc/synthesizer/function.lux43
-rw-r--r--new-luxc/source/luxc/synthesizer/loop.lux14
-rw-r--r--new-luxc/source/luxc/synthesizer/structure.lux28
-rw-r--r--new-luxc/source/luxc/synthesizer/variable.lux44
23 files changed, 385 insertions, 379 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
index 04d8d58b7..a7b872de5 100644
--- a/new-luxc/source/luxc/analyser.lux
+++ b/new-luxc/source/luxc/analyser.lux
@@ -113,7 +113,7 @@
[[funcT =func] (&&common;with-unknown-type
(analyse func))]
(case =func
- (#la;Definition def-name)
+ [_ (#;Symbol def-name)]
(do @
[[def-type def-anns def-value] (meta;find-def def-name)]
(if (meta;macro? def-anns)
diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux
index b17dbcbfd..29256865a 100644
--- a/new-luxc/source/luxc/analyser/case.lux
+++ b/new-luxc/source/luxc/analyser/case.lux
@@ -25,6 +25,7 @@
(exception: #export Cannot-Match-Type-With-Pattern)
(exception: #export Sum-Type-Has-No-Case)
(exception: #export Unrecognized-Pattern-Syntax)
+(exception: #export Cannot-Simplify-Type-For-Pattern-Matching)
(def: (pattern-error type pattern)
(-> Type Code Text)
@@ -51,7 +52,7 @@
[type' (&;with-type-env
(tc;read id))]
(simplify-case-type type'))
- (&;fail (format "Cannot simplify type for pattern-matching: " (%type type)))))
+ (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type type))))
(#;Named name unnamedT)
(simplify-case-type unnamedT)
@@ -98,26 +99,26 @@
[outputA (&scope;with-local [name inputT]
next)
idx &scope;next-local]
- (wrap [(#la;BindP idx) outputA])))
+ (wrap [(` ("lux case bind" (~ (code;nat idx)))) outputA])))
[cursor (#;Symbol ident)]
(&;with-cursor cursor
(&;fail (format "Symbols must be unqualified inside patterns: " (%ident ident))))
- (^template [<type> <code-tag> <pattern-tag>]
+ (^template [<type> <code-tag>]
[cursor (<code-tag> test)]
(&;with-cursor cursor
(do meta;Monad<Meta>
[_ (&;with-type-env
(tc;check inputT <type>))
outputA next]
- (wrap [(<pattern-tag> test) outputA]))))
- ([Bool #;Bool #la;BoolP]
- [Nat #;Nat #la;NatP]
- [Int #;Int #la;IntP]
- [Deg #;Deg #la;DegP]
- [Frac #;Frac #la;FracP]
- [Text #;Text #la;TextP])
+ (wrap [pattern outputA]))))
+ ([Bool #;Bool]
+ [Nat #;Nat]
+ [Int #;Int]
+ [Deg #;Deg]
+ [Frac #;Frac]
+ [Text #;Text])
(^ [cursor (#;Tuple (list))])
(&;with-cursor cursor
@@ -125,7 +126,7 @@
[_ (&;with-type-env
(tc;check inputT Unit))
outputA next]
- (wrap [(#la;TupleP (list)) outputA])))
+ (wrap [(` ("lux case tuple" [])) outputA])))
(^ [cursor (#;Tuple (list singleton))])
(analyse-pattern #;None inputT singleton next)
@@ -165,7 +166,8 @@
[nextA next]
(wrap [(list) nextA]))
matches)]
- (wrap [(#la;TupleP memberP+) thenA])))
+ (wrap [(` ("lux case tuple" [(~@ memberP+)]))
+ thenA])))
_
(&;fail (pattern-error inputT pattern))
@@ -202,11 +204,11 @@
(type;variant (list;drop (n.dec num-cases) flat-sum))
(` [(~@ values)])
next)]
- (wrap [(#la;VariantP idx num-cases testP)
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
nextA]))
(do meta;Monad<Meta>
[[testP nextA] (analyse-pattern #;None case-type (` [(~@ values)]) next)]
- (wrap [(#la;VariantP idx num-cases testP)
+ (wrap [(` ("lux case variant" (~ (code;nat idx)) (~ (code;nat num-cases)) (~ testP)))
nextA])))
_
@@ -245,10 +247,9 @@
(function [[patternT bodyT]]
(analyse-pattern #;None inputT patternT (analyse bodyT)))
branchesT)
- _ (case (monad;fold e;Monad<Error>
- &&coverage;merge
- (|> outputH product;left &&coverage;determine)
- (list/map (|>. product;left &&coverage;determine) outputT))
+ outputHC (|> outputH product;left &&coverage;determine)
+ outputTC (monad;map @ (|>. product;left &&coverage;determine) outputT)
+ _ (case (monad;fold e;Monad<Error> &&coverage;merge outputHC outputTC)
(#e;Success coverage)
(if (&&coverage;exhaustive? coverage)
(wrap [])
@@ -256,4 +257,4 @@
(#e;Error error)
(&;fail error))]
- (wrap (#la;Case inputA (#;Cons outputH outputT))))))
+ (wrap (` ("lux case" (~ inputA) (~ (code;record (list& outputH outputT)))))))))
diff --git a/new-luxc/source/luxc/analyser/case/coverage.lux b/new-luxc/source/luxc/analyser/case/coverage.lux
index cb066a2bf..554aea1a8 100644
--- a/new-luxc/source/luxc/analyser/case/coverage.lux
+++ b/new-luxc/source/luxc/analyser/case/coverage.lux
@@ -1,13 +1,17 @@
(;module:
lux
(lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
eq)
- (data [bool "B/" Eq<Bool>]
+ (data [bool "bool/" Eq<Bool>]
[number]
["e" error "error/" Monad<Error>]
- (coll [list "L/" Fold<List>]
- ["D" dict])))
- (luxc (lang ["la" analysis])))
+ text/format
+ (coll [list "list/" Fold<List>]
+ [dict #+ Dict]))
+ [meta "meta/" Monad<Meta>])
+ (luxc ["&" base]
+ (lang ["la" analysis])))
## The coverage of a pattern-matching expression summarizes how well
## all the possible values of an input are being covered by the
@@ -24,7 +28,7 @@
(type: #export #rec Coverage
#Partial
(#Bool Bool)
- (#Variant Nat (D;Dict Nat Coverage))
+ (#Variant Nat (Dict Nat Coverage))
(#Seq Coverage Coverage)
(#Alt Coverage Coverage)
#Exhaustive)
@@ -38,52 +42,60 @@
_
false))
+(exception: #export Unknown-Pattern)
+
(def: #export (determine pattern)
- (-> la;Pattern Coverage)
+ (-> la;Pattern (Meta Coverage))
(case pattern
## Binding amounts to exhaustive coverage because any value can be
## matched that way.
## Unit [] amounts to exhaustive coverage because there is only one
## possible value, so matching against it covers all cases.
- (^or (#la;BindP _) (^ (#la;TupleP (list))))
- #Exhaustive
+ (^or (^code ("lux case bind" (~ _))) (^code ("lux case tuple" [])))
+ (meta/wrap #Exhaustive)
- (^ (#la;TupleP (list singleton)))
+ (^code ("lux case tuple" [(~ singleton)]))
(determine singleton)
## Primitive patterns always have partial coverage because there
## are too many possibilities as far as values go.
- (^or (#la;NatP _) (#la;IntP _) (#la;DegP _)
- (#la;FracP _) (#la;TextP _))
- #Partial
+ (^or [_ (#;Nat _)] [_ (#;Int _)] [_ (#;Deg _)]
+ [_ (#;Frac _)] [_ (#;Text _)])
+ (meta/wrap #Partial)
## Bools are the exception, since there is only "true" and
## "false", which means it is possible for boolean
## pattern-matching to become exhaustive if complementary parts meet.
- (#la;BoolP value)
- (#Bool value)
+ [_ (#;Bool value)]
+ (meta/wrap (#Bool value))
## Tuple patterns can be exhaustive if there is exhaustiveness for all of
## their sub-patterns.
- (#la;TupleP subs)
+ (^code ("lux case tuple" [(~@ subs)]))
(loop [subs subs]
(case subs
#;Nil
- #Exhaustive
+ (meta/wrap #Exhaustive)
(#;Cons sub subs')
- (let [post (recur subs')]
+ (do meta;Monad<Meta>
+ [pre (determine sub)
+ post (recur subs')]
(if (exhaustive? post)
- (determine sub)
- (#Seq (determine sub)
- post)))))
+ (wrap pre)
+ (wrap (#Seq pre post))))))
## Variant patterns can be shown to be exhaustive if all the possible
## cases are handled exhaustively.
- (#la;VariantP tag-id num-tags sub)
- (#Variant num-tags
- (|> (D;new number;Hash<Nat>)
- (D;put tag-id (determine sub))))))
+ (^code ("lux case variant" (~ [_ (#;Nat tag-id)]) (~ [_ (#;Nat num-tags)]) (~ sub)))
+ (do meta;Monad<Meta>
+ [=sub (determine sub)]
+ (wrap (#Variant num-tags
+ (|> (dict;new number;Hash<Nat>)
+ (dict;put tag-id =sub)))))
+
+ _
+ (&;throw Unknown-Pattern (%code pattern))))
(def: (xor left right)
(-> Bool Bool Bool)
@@ -116,11 +128,11 @@
true
[(#Bool sideR) (#Bool sideS)]
- (B/= sideR sideS)
+ (bool/= sideR sideS)
[(#Variant allR casesR) (#Variant allS casesS)]
(and (n.= allR allS)
- (:: (D;Eq<Dict> =) = casesR casesS))
+ (:: (dict;Eq<Dict> =) = casesR casesS))
[(#Seq leftR rightR) (#Seq leftS rightS)]
(and (= leftR leftS)
@@ -166,23 +178,23 @@
(cond (not (n.= allSF allA))
(e;fail "Variants do not match.")
- (:: (D;Eq<Dict> Eq<Coverage>) = casesSF casesA)
+ (:: (dict;Eq<Dict> Eq<Coverage>) = casesSF casesA)
redundant-pattern
## else
(do e;Monad<Error>
[casesM (monad;fold @
(function [[tagA coverageA] casesSF']
- (case (D;get tagA casesSF')
+ (case (dict;get tagA casesSF')
(#;Some coverageSF)
(do @
[coverageM (merge coverageA coverageSF)]
- (wrap (D;put tagA coverageM casesSF')))
+ (wrap (dict;put tagA coverageM casesSF')))
#;None
- (wrap (D;put tagA coverageA casesSF'))))
- casesSF (D;entries casesA))]
- (wrap (if (let [case-coverages (D;values casesM)]
+ (wrap (dict;put tagA coverageA casesSF'))))
+ casesSF (dict;entries casesA))]
+ (wrap (if (let [case-coverages (dict;values casesM)]
(and (n.= allSF (list;size case-coverages))
(list;every? exhaustive? case-coverages)))
#Exhaustive
@@ -272,9 +284,9 @@
#;None
(case (list;reverse possibilities)
(#;Cons last prevs)
- (wrap (L/fold (function [left right] (#Alt left right))
- last
- prevs))
+ (wrap (list/fold (function [left right] (#Alt left right))
+ last
+ prevs))
#;Nil
(undefined)))))
diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux
index 55896480e..3d2da6326 100644
--- a/new-luxc/source/luxc/analyser/function.lux
+++ b/new-luxc/source/luxc/analyser/function.lux
@@ -6,11 +6,13 @@
[text]
text/format
(coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
- [meta #+ Monad<Meta>]
- (meta [type]
+ [meta]
+ (meta [code]
+ [type]
(type ["tc" check])))
(luxc ["&" base]
- (lang ["la" analysis #+ Analysis])
+ (lang ["la" analysis #+ Analysis]
+ [";L" variable #+ Variable])
["&;" scope]
(analyser ["&;" common]
["&;" inference])))
@@ -21,7 +23,7 @@
## [Analysers]
(def: #export (analyse-function analyse func-name arg-name body)
(-> &;Analyser Text Text Code (Meta Analysis))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[functionT meta;expected-type]
(loop [expectedT functionT]
(&;with-stacked-errors
@@ -80,7 +82,9 @@
))))))
(#;Function inputT outputT)
- (<| (:: @ map (|>. #la;Function))
+ (<| (:: @ map (function [[scope bodyA]]
+ (` ("lux function" [(~@ (list/map code;int (variableL;environment scope)))]
+ (~ bodyA)))))
&;with-scope
## Functions have access not only to their argument, but
## also to themselves, through a local variable.
@@ -99,7 +103,7 @@
(function [_]
(Cannot-Apply-Function (format " Function: " (%type funcT) "\n"
"Arguments: " (|> args (list/map %code) (text;join-with " ")))))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[expected meta;expected-type
[applyT argsA] (&inference;apply-function analyse funcT args)
_ (&;with-type-env
diff --git a/new-luxc/source/luxc/analyser/primitive.lux b/new-luxc/source/luxc/analyser/primitive.lux
index 0023e43e0..c7f7243fd 100644
--- a/new-luxc/source/luxc/analyser/primitive.lux
+++ b/new-luxc/source/luxc/analyser/primitive.lux
@@ -1,8 +1,9 @@
(;module:
lux
(lux (control monad)
- [meta #+ Monad<Meta>]
- (meta (type ["TC" check])))
+ [meta]
+ (meta [code]
+ (type ["tc" check])))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis])))
@@ -10,24 +11,24 @@
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
(-> <type> (Meta Analysis))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[expected meta;expected-type
_ (&;with-type-env
- (TC;check expected <type>))]
+ (tc;check expected <type>))]
(wrap (<tag> value))))]
- [analyse-bool Bool #la;Bool]
- [analyse-nat Nat #la;Nat]
- [analyse-int Int #la;Int]
- [analyse-deg Deg #la;Deg]
- [analyse-frac Frac #la;Frac]
- [analyse-text Text #la;Text]
+ [analyse-bool Bool code;bool]
+ [analyse-nat Nat code;nat]
+ [analyse-int Int code;int]
+ [analyse-deg Deg code;deg]
+ [analyse-frac Frac code;frac]
+ [analyse-text Text code;text]
)
(def: #export analyse-unit
(Meta Analysis)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[expected meta;expected-type
_ (&;with-type-env
- (TC;check expected Unit))]
- (wrap #la;Unit)))
+ (tc;check expected Unit))]
+ (wrap (` []))))
diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux
index f64c537cb..0fad41958 100644
--- a/new-luxc/source/luxc/analyser/procedure/common.lux
+++ b/new-luxc/source/luxc/analyser/procedure/common.lux
@@ -7,8 +7,9 @@
(coll [list "list/" Functor<List>]
[array]
[dict #+ Dict]))
- [meta #+ Monad<Meta>]
- (meta (type ["tc" check]))
+ [meta]
+ (meta [code]
+ (type ["tc" check]))
[io])
(luxc ["&" base]
(lang ["la" analysis])
@@ -48,7 +49,7 @@
(function [analyse eval args]
(let [num-actual (list;size args)]
(if (n.= num-expected num-actual)
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[argsA (monad;map @
(function [[argT argC]]
(&;with-expected-type argT
@@ -57,7 +58,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected output-type))]
- (wrap (#la;Procedure proc argsA)))
+ (wrap (la;procedure proc argsA)))
(&;fail (wrong-arity proc num-expected num-actual)))))))
(def: #export (nullary valueT proc)
@@ -95,7 +96,7 @@
(function [[var-id varT]]
(case args
(^ (list opC))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[opA (&;with-expected-type (type (io;IO varT))
(analyse opC))
outputT (&;with-type-env
@@ -103,7 +104,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected outputT))]
- (wrap (#la;Procedure proc (list opA))))
+ (wrap (la;procedure proc (list opA))))
_
(&;fail (wrong-arity proc +1 (list;size args))))))))
@@ -352,7 +353,7 @@
(function [[var-id varT]]
(case args
(^ (list initC))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[initA (&;with-expected-type varT
(analyse initC))
outputT (&;with-type-env
@@ -360,7 +361,7 @@
expected meta;expected-type
_ (&;with-type-env
(tc;check expected outputT))]
- (wrap (#la;Procedure proc (list initA))))
+ (wrap (la;procedure proc (list initA))))
_
(&;fail (wrong-arity proc +1 (list;size args))))))))
diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 4db7b4dda..015379a1b 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -15,7 +15,8 @@
[array]
[dict #+ Dict]))
[meta "meta/" Monad<Meta>]
- (meta ["s" syntax]
+ (meta [code]
+ ["s" syntax]
[type]
(type ["tc" check]))
[host])
@@ -156,7 +157,7 @@
[arrayA (&;with-expected-type (type (Array varT))
(analyse arrayC))
_ (&;infer Nat)]
- (wrap (#la;Procedure proc (list arrayA))))
+ (wrap (la;procedure proc (list arrayA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -196,7 +197,7 @@
(&;fail (invalid-array-type expectedT)))))
_ (&;assert "Must have at least 1 level of nesting in array type."
(n.> +0 level))]
- (wrap (#la;Procedure proc (list (#la;Nat (n.dec level)) (#la;Text elem-class) lengthA))))
+ (wrap (la;procedure proc (list (code;nat (n.dec level)) (code;text elem-class) lengthA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))
@@ -275,7 +276,7 @@
idxA (&;with-expected-type Nat
(analyse idxC))
_ (&;infer elemT)]
- (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA arrayA))))
+ (wrap (la;procedure proc (list (code;text elem-class) idxA arrayA))))
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -298,7 +299,7 @@
valueA (&;with-expected-type valueT
(analyse valueC))
_ (&;infer (type (Array elemT)))]
- (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA valueA arrayA))))
+ (wrap (la;procedure proc (list (code;text elem-class) idxA valueA arrayA))))
_
(&;fail (@;wrong-arity proc +3 (list;size args))))))))
@@ -321,7 +322,7 @@
(do meta;Monad<Meta>
[expectedT meta;expected-type
_ (check-object expectedT)]
- (wrap (#la;Procedure proc (list))))
+ (wrap (la;procedure proc (list))))
_
(&;fail (@;wrong-arity proc +0 (list;size args))))))
@@ -340,7 +341,7 @@
(tc;read var-id))
_ (check-object objectT)
_ (&;infer Bool)]
- (wrap (#la;Procedure proc (list objectA))))
+ (wrap (la;procedure proc (list objectA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -359,7 +360,7 @@
(tc;read var-id))
_ (check-object monitorT)
exprA (analyse exprC)]
- (wrap (#la;Procedure proc (list monitorA exprA))))
+ (wrap (la;procedure proc (list monitorA exprA))))
_
(&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -465,7 +466,7 @@
(wrap [])
(&;throw Not-Throwable exception-class)))
_ (&;infer Bottom)]
- (wrap (#la;Procedure proc (list exceptionA))))
+ (wrap (la;procedure proc (list exceptionA))))
_
(&;fail (@;wrong-arity proc +1 (list;size args))))))))
@@ -480,7 +481,7 @@
(do meta;Monad<Meta>
[_ (load-class class)
_ (&;infer (#;Primitive "java.lang.Class" (list (#;Primitive class (list)))))]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (wrap (la;procedure proc (list (code;text class)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -509,7 +510,7 @@
(if ?
(do @
[_ (&;infer Bool)]
- (wrap (#la;Procedure proc (list (#la;Text class)))))
+ (wrap (la;procedure proc (list (code;text class)))))
(&;throw Cannot-Be-Instance (format object-class " !<= " class))))
_
@@ -801,7 +802,8 @@
(do meta;Monad<Meta>
[[fieldT final?] (static-field class field)
[unboxed castT] (infer-out fieldT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed)))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -824,7 +826,8 @@
_ (&;with-type-env
(tc;check fieldT valueT))
_ (&;infer Unit)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) valueA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -843,7 +846,8 @@
[[objectT objectA] (analyse-object class analyse objectC)
[fieldT final?] (virtual-field class field objectT)
[unboxed castT] (infer-out fieldT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) objectA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field)
+ (code;text unboxed) objectA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -867,7 +871,7 @@
_ (&;with-type-env
(tc;check fieldT valueT))
_ (&;infer objectT)]
- (wrap (#la;Procedure proc (list (#la;Text class) (#la;Text field) (#la;Text unboxed) valueA objectA))))
+ (wrap (la;procedure proc (list (code;text class) (code;text field) (code;text unboxed) valueA objectA))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))
@@ -1089,8 +1093,9 @@
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List la;Analysis) (List la;Analysis))
(|> inputsA
- (list;zip2 (list/map (|>. #la;Text) typesT))
- (list/map (|>. #la;Product))))
+ (list;zip2 (list/map code;text typesT))
+ (list/map (function [[type value]]
+ (la;product (list type value))))))
(def: (sub-type-analyser analyse)
(-> &;Analyser &;Analyser)
@@ -1113,8 +1118,8 @@
[methodT exceptionsT] (methods class method #Static argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1136,8 +1141,8 @@
_
(undefined))]
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) objectA (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) objectA (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1153,8 +1158,8 @@
[methodT exceptionsT] (methods class method #Special argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (code;text method)
+ (code;text unboxed) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1175,8 +1180,9 @@
[methodT exceptionsT] (methods class-name method #Interface argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class-name) (#la;Text method)
- (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc
+ (list& (code;text class-name) (code;text method) (code;text unboxed)
+ (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1192,7 +1198,7 @@
[methodT exceptionsT] (constructor-methods class argsT)
[outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
[unboxed castT] (infer-out outputT)]
- (wrap (#la;Procedure proc (list& (#la;Text class) (decorate-inputs argsT argsA)))))
+ (wrap (la;procedure proc (list& (code;text class) (decorate-inputs argsT argsA)))))
_
(&;fail (format "Wrong syntax for '" proc "'.")))))
diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux
index 4a2f6dbc5..5bc1f96c9 100644
--- a/new-luxc/source/luxc/analyser/reference.lux
+++ b/new-luxc/source/luxc/analyser/reference.lux
@@ -2,9 +2,11 @@
lux
(lux (control monad)
[meta]
- (meta (type ["tc" check])))
+ (meta [code]
+ (type ["tc" check])))
(luxc ["&" base]
- (lang ["la" analysis #+ Analysis])
+ (lang ["la" analysis #+ Analysis]
+ [";L" variable #+ Variable])
["&;" scope]))
## [Analysers]
@@ -15,7 +17,7 @@
expectedT meta;expected-type
_ (&;with-type-env
(tc;check expectedT actualT))]
- (wrap (#la;Definition def-name))))
+ (wrap (code;symbol def-name))))
(def: (analyse-variable var-name)
(-> Text (Meta (Maybe Analysis)))
@@ -27,7 +29,7 @@
[expectedT meta;expected-type
_ (&;with-type-env
(tc;check expectedT actualT))]
- (wrap (#;Some (#la;Variable ref))))
+ (wrap (#;Some (` ((~ (code;int (variableL;from-ref ref))))))))
#;None
(wrap #;None))))
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index 7720202d8..d523065ea 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -120,7 +120,7 @@
[leftA (&;with-expected-type leftT
(analyse leftC))
rightA (recur rightT rightC)]
- (wrap (#la;Product leftA rightA)))
+ (wrap (` [(~ leftA) (~ rightA)])))
## If the tuple runs out, whatever expression is the last gets
## matched to the remaining type.
diff --git a/new-luxc/source/luxc/generator/expression.jvm.lux b/new-luxc/source/luxc/generator/expression.jvm.lux
index 624070145..5eb8d7c47 100644
--- a/new-luxc/source/luxc/generator/expression.jvm.lux
+++ b/new-luxc/source/luxc/generator/expression.jvm.lux
@@ -9,10 +9,10 @@
(meta ["s" syntax]))
(luxc ["&" base]
(host ["$" jvm])
- (lang ["ls" synthesis])
+ (lang ["ls" synthesis]
+ [";L" variable #+ Variable Register])
["&;" analyser]
["&;" synthesizer]
- (synthesizer [";S" function])
(generator ["&;" common]
["&;" primitive]
["&;" structure]
@@ -50,7 +50,7 @@
(&structure;generate-tuple generate members)
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (if (functionS;captured? var)
+ (if (variableL;captured? var)
(&reference;generate-captured var)
(&reference;generate-variable var))
diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux
index 1b0939856..ed90d3aa2 100644
--- a/new-luxc/source/luxc/generator/function.jvm.lux
+++ b/new-luxc/source/luxc/generator/function.jvm.lux
@@ -11,10 +11,10 @@
["$d" def]
["$i" inst]))
(lang ["la" analysis]
- ["ls" synthesis])
+ ["ls" synthesis]
+ [";L" variable #+ Variable])
["&;" analyser]
["&;" synthesizer]
- (synthesizer [function])
(generator ["&;" common]
["&;" runtime])))
@@ -40,11 +40,11 @@
($t;method (list) (#;Some ($t;class class (list))) (list)))
(def: (captured-args env)
- (-> (List ls;Variable) (List $;Type))
+ (-> (List Variable) (List $;Type))
(list;repeat (list;size env) $Object))
(def: (init-method env arity)
- (-> (List ls;Variable) ls;Arity $;Method)
+ (-> (List Variable) ls;Arity $;Method)
(if (poly-arg? arity)
($t;method (list;concat (list (captured-args env)
(list $t;int)
@@ -95,7 +95,7 @@
$i;fuse))
(def: (with-captured env)
- (-> (List ls;Variable) $;Def)
+ (-> (List Variable) $;Def)
(|> (list;enumerate env)
(list/map (function [[env-idx env-source]]
($d;field #$;Private $;finalF (captured env-idx) $Object)))
@@ -111,11 +111,11 @@
id))
(def: (instance class arity env)
- (-> Text ls;Arity (List ls;Variable) $;Inst)
+ (-> Text ls;Arity (List Variable) $;Inst)
(let [captureI (|> env
(list/map (function [source]
- (if (function;captured? source)
- ($i;GETFIELD class (captured (function;captured-idx source)) $Object)
+ (if (variableL;captured? source)
+ ($i;GETFIELD class (captured (variableL;captured-register source)) $Object)
($i;ALOAD (int-to-nat source)))))
$i;fuse)
argsI (if (poly-arg? arity)
@@ -130,7 +130,7 @@
($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))
(def: (with-reset class arity env)
- (-> Text ls;Arity (List ls;Variable) $;Def)
+ (-> Text ls;Arity (List Variable) $;Def)
($d;method #$;Public $;noneM "reset" (reset-method class)
(if (poly-arg? arity)
(let [env-size (list;size env)
@@ -173,7 +173,7 @@
($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false))))
(def: (with-init class env arity)
- (-> Text (List ls;Variable) ls;Arity $;Def)
+ (-> Text (List Variable) ls;Arity $;Def)
(let [env-size (list;size env)
offset-partial (: (-> Nat Nat)
(|>. n.inc (n.+ env-size)))
@@ -202,7 +202,7 @@
$i;RETURN))))
(def: (with-apply class env function-arity @begin bodyI apply-arity)
- (-> Text (List ls;Variable) ls;Arity $;Label $;Inst ls;Arity
+ (-> Text (List Variable) ls;Arity $;Label $;Inst ls;Arity
$;Def)
(let [num-partials (n.dec function-arity)
@default ($;new-label [])
@@ -270,7 +270,7 @@
(def: #export (with-function generate class env arity body)
(-> (-> ls;Synthesis (Meta $;Inst))
- Text (List ls;Variable) ls;Arity ls;Synthesis
+ Text (List Variable) ls;Arity ls;Synthesis
(Meta [$;Def $;Inst]))
(do meta;Monad<Meta>
[@begin $i;make-label
@@ -299,7 +299,7 @@
(def: #export (generate-function generate env arity body)
(-> (-> ls;Synthesis (Meta $;Inst))
- (List ls;Variable) ls;Arity ls;Synthesis
+ (List Variable) ls;Arity ls;Synthesis
(Meta $;Inst))
(do meta;Monad<Meta>
[function-class (:: @ map %code (meta;gensym "function"))
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index d94ded890..a61b7f0fe 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -19,7 +19,6 @@
["ls" synthesis])
["&;" analyser]
["&;" synthesizer]
- (synthesizer [function])
(generator ["&;" common]
["&;" runtime])))
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index 5fb779d41..bc57d6a2b 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -25,7 +25,6 @@
["&;" analyser]
(analyser (procedure ["&;" host]))
["&;" synthesizer]
- (synthesizer [function])
(generator ["&;" common]
["&;" runtime]))
["@" ../common])
diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux
index 3c8cbc552..9af511167 100644
--- a/new-luxc/source/luxc/generator/reference.jvm.lux
+++ b/new-luxc/source/luxc/generator/reference.jvm.lux
@@ -7,12 +7,13 @@
(host ["$" jvm]
(jvm ["$t" type]
["$i" inst]))
- (lang ["ls" synthesis])
+ (lang ["ls" synthesis]
+ [";L" variable #+ Variable])
(generator [";G" common]
[";G" function])))
(def: #export (generate-captured variable)
- (-> ls;Variable (Meta $;Inst))
+ (-> Variable (Meta $;Inst))
(do meta;Monad<Meta>
[function-class commonG;function]
(wrap (|>. ($i;ALOAD +0)
@@ -21,7 +22,7 @@
commonG;$Object)))))
(def: #export (generate-variable variable)
- (-> ls;Variable (Meta $;Inst))
+ (-> Variable (Meta $;Inst))
(meta/wrap ($i;ALOAD (int-to-nat variable))))
(def: #export (generate-definition [def-module def-name])
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
index 7a4ae37ac..03e4c867f 100644
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ b/new-luxc/source/luxc/lang/analysis.lux
@@ -1,35 +1,13 @@
(;module:
lux
(lux [function]
- (data (coll [list "L/" Fold<List>]))))
-
-(type: #export #rec Pattern
- (#BoolP Bool)
- (#NatP Nat)
- (#IntP Int)
- (#DegP Deg)
- (#FracP Frac)
- (#TextP Text)
- (#TupleP (List Pattern))
- (#VariantP Nat Nat Pattern)
- (#BindP Nat))
-
-(type: #export #rec Analysis
- #Unit
- (#Bool Bool)
- (#Nat Nat)
- (#Int Int)
- (#Deg Deg)
- (#Frac Frac)
- (#Text Text)
- (#Sum (Either Analysis Analysis))
- (#Product Analysis Analysis)
- (#Case Analysis (List [Pattern Analysis]))
- (#Function Scope Analysis)
- (#Apply Analysis Analysis)
- (#Procedure Text (List Analysis))
- (#Variable Ref)
- (#Definition Ident))
+ (data (coll [list "list/" Fold<List>]))
+ (meta [code]))
+ (luxc (lang [";L" variable #+ Variable])))
+
+(type: #export Pattern Code)
+
+(type: #export Analysis Code)
## Variants get analysed as binary sum types for the sake of semantic
## simplicity.
@@ -39,28 +17,34 @@
(do-template [<name> <side>]
[(def: (<name> inner)
(-> Analysis Analysis)
- (#Sum (<side> inner)))]
+ (` (<side> (~ inner))))]
+
+ [sum-left "lux sum left"]
+ [sum-right "lux sum right"])
- [sum-left #;Left]
- [sum-right #;Right])
+(def: (local-variable idx)
+ (-> Nat Int)
+ (nat-to-int idx))
(def: #export (sum tag size temp value)
(-> Nat Nat Nat Analysis Analysis)
(if (n.= (n.dec size) tag)
(if (n.= +1 tag)
(sum-right value)
- (L/fold (function;const sum-left)
- (sum-right value)
- (list;n.range +0 (n.- +2 tag))))
- (L/fold (function;const sum-left)
- (case value
- (#Sum _)
- (#Case value (list [(#BindP temp)
- (#Variable (#;Local temp))]))
-
- _
- value)
- (list;n.range +0 tag))))
+ (list/fold (function;const sum-left)
+ (sum-right value)
+ (list;n.range +0 (n.- +2 tag))))
+ (list/fold (function;const sum-left)
+ (case value
+ (^or (^code ("lux sum left" (~ inner)))
+ (^code ("lux sum right" (~ inner))))
+ (` ("lux case" (~ value)
+ {("lux case bind" (~ (code;nat temp)))
+ ((~ (code;int (local-variable temp))))}))
+
+ _
+ value)
+ (list;n.range +0 tag))))
## Tuples get analysed into binary products for the sake of semantic
## simplicity, since products/pairs can encode tuples of any length
@@ -70,13 +54,13 @@
(-> (List Analysis) Analysis)
(case members
#;Nil
- #Unit
+ (` [])
(#;Cons singleton #;Nil)
singleton
(#;Cons left right)
- (#Product left (product right))))
+ (` [(~ left) (~ (product right))])))
## Function application gets analysed into single-argument
## applications, since every other kind of application can be encoded
@@ -84,6 +68,44 @@
(def: #export (apply args func)
(-> (List Analysis) Analysis Analysis)
- (L/fold (function [arg func] (#Apply arg func))
- func
- args))
+ (list/fold (function [arg func]
+ (` ("lux apply" (~ arg) (~ func))))
+ func
+ args))
+
+(def: #export (procedure name args)
+ (-> Text (List Analysis) Analysis)
+ (` ((~ (code;text name)) (~@ args))))
+
+(def: #export (var idx)
+ (-> Variable Analysis)
+ (` ((~ (code;int idx)))))
+
+(def: #export (unfold-tuple analysis)
+ (-> Analysis (List Analysis))
+ (case analysis
+ (^code [(~ left) (~ right)])
+ (#;Cons left (unfold-tuple right))
+
+ _
+ (list analysis)))
+
+(def: #export (unfold-variant analysis)
+ (-> Analysis (Maybe [Nat Bool Analysis]))
+ (loop [so-far +0
+ variantA analysis]
+ (case variantA
+ (^code ("lux sum left" (~ valueA)))
+ (case valueA
+ (^or (^code ("lux sum left" (~ _)))
+ (^code ("lux sum right" (~ _))))
+ (recur (n.inc so-far) valueA)
+
+ _
+ (#;Some [so-far false valueA]))
+
+ (^code ("lux sum right" (~ valueA)))
+ (#;Some [(n.inc so-far) true valueA])
+
+ _
+ #;None)))
diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux
index 96053edc0..3207c41b4 100644
--- a/new-luxc/source/luxc/lang/synthesis.lux
+++ b/new-luxc/source/luxc/lang/synthesis.lux
@@ -2,8 +2,6 @@
lux)
(def: #export Arity Nat)
-(def: #export Register Nat)
-(def: #export Variable Int)
(type: #export Synthesis Code)
diff --git a/new-luxc/source/luxc/lang/variable.lux b/new-luxc/source/luxc/lang/variable.lux
new file mode 100644
index 000000000..c04269e63
--- /dev/null
+++ b/new-luxc/source/luxc/lang/variable.lux
@@ -0,0 +1,47 @@
+(;module:
+ lux
+ (lux (data (coll [list "list/" Functor<List>]))))
+
+(def: #export Variable Int)
+(def: #export Register Nat)
+
+(def: #export (captured register)
+ (-> Nat Variable)
+ (|> register n.inc nat-to-int (i.* -1)))
+
+(def: #export (local register)
+ (-> Nat Variable)
+ (nat-to-int register))
+
+(def: #export (local-register variable)
+ (-> Variable Register)
+ (int-to-nat variable))
+
+(def: #export (captured-register variable)
+ (-> Variable Register)
+ (|> variable (i.* -1) int-to-nat n.dec))
+
+(do-template [<name> <comp>]
+ [(def: #export (<name> var)
+ (-> Variable Bool)
+ (<comp> 0 var))]
+
+ [self? i.=]
+ [local? i.>]
+ [captured? i.<]
+ )
+
+(def: #export (from-ref ref)
+ (-> Ref Variable)
+ (case ref
+ (#;Local register)
+ (local register)
+
+ (#;Captured register)
+ (captured register)))
+
+(def: #export (environment scope)
+ (-> Scope (List Variable))
+ (|> scope
+ (get@ [#;captured #;mappings])
+ (list/map (function [[_ [_ ref]]] (from-ref ref)))))
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
index e1eb67bd7..e6730c5a3 100644
--- a/new-luxc/source/luxc/synthesizer.lux
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -12,14 +12,14 @@
["s" syntax]))
(luxc ["&" base]
(lang ["la" analysis]
- ["ls" synthesis])
- (synthesizer ["&&;" structure]
- ["&&;" case]
+ ["ls" synthesis]
+ [";L" variable #+ Variable])
+ (synthesizer ["&&;" case]
["&&;" function]
["&&;" loop])
))
-(def: init-env (List ls;Variable) (list))
+(def: init-env (List Variable) (list))
(def: init-resolver (Dict Int Int) (dict;new number;Hash<Int>))
(def: (prepare-body inner-arity arity body)
@@ -28,10 +28,6 @@
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))))
@@ -43,7 +39,7 @@
(~ elseS))))
(def: (function$ arity environment body)
- (-> ls;Arity (List ls;Variable) ls;Synthesis ls;Synthesis)
+ (-> ls;Arity (List Variable) ls;Synthesis ls;Synthesis)
(` ("lux function" (~ (code;nat arity))
[(~@ (list/map code;int environment))]
(~ body))))
@@ -53,7 +49,7 @@
(` ((~ (code;nat tag)) (~ (code;bool last?)) (~ valueS))))
(def: (var$ var)
- (-> ls;Variable ls;Synthesis)
+ (-> Variable ls;Synthesis)
(` ((~ (code;int var)))))
(def: (procedure$ name argsS)
@@ -70,16 +66,17 @@
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))
+ (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)])))
+ (^code ((~ [_ (#;Int var)])))]))
+ (variableL;local? var)
+ (n.= input-register (int-to-nat var)))
inputS
- (^ (list [(#la;BindP register) bodyA]))
+ (^ (list [(^code ("lux case bind" (~ [_ (#;Nat 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])))
+ (^or (^ (list [(^code true) thenA] [(^code false) elseA]))
+ (^ (list [(^code false) elseA] [(^code true) thenA])))
(if$ inputS (synthesize thenA) (synthesize elseA))
(#;Cons [lastP lastA] prevsPA)
@@ -98,6 +95,28 @@
(undefined)
)))
+(def: (synthesize-apply synthesize outer-arity num-locals exprA)
+ (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis)
+ (let [[funcA argsA] (&&function;unfold-apply exprA)
+ funcS (synthesize funcA)
+ argsS (list/map synthesize argsA)]
+ (case funcS
+ (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
+ (and (n.= _arity (list;size argsS))
+ (not (&&loop;contains-self-reference? _bodyS)))
+ [(s;run _env (p;some s;int)) (#e;Success _env)])
+ (let [register-offset (if (&&function;top? outer-arity)
+ num-locals
+ (|> outer-arity n.inc (n.+ num-locals)))]
+ (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
+ (~ (&&loop;adjust _env register-offset _bodyS)))))
+
+ (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
+ (call$ funcS' (list/compose argsS' argsS))
+
+ _
+ (call$ funcS argsS))))
+
(def: #export (synthesize analysis)
(-> la;Analysis ls;Synthesis)
(loop [outer-arity +0
@@ -105,53 +124,39 @@
num-locals +0
exprA analysis]
(case exprA
- #la;Unit
- (' [])
-
- (^template [<from> <to>]
- (<from> value)
- (<to> value))
- ([#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 _)
- (` [(~@ (list/map (recur +0 resolver num-locals) (&&structure;unfold-tuple exprA)))])
-
- (#la;Sum choice)
- (let [[tag last? value] (&&structure;unfold-variant choice)]
+ (^code [(~ _left) (~ _right)])
+ (` [(~@ (list/map (recur +0 resolver num-locals) (la;unfold-tuple exprA)))])
+
+ (^or (^code ("lux sum left" (~ _)))
+ (^code ("lux sum right" (~ _))))
+ (let [[tag last? value] (maybe;assume (la;unfold-variant exprA))]
(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)
- (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)
- (var$ (let [var (&&function;to-captured register)]
- (maybe;default var (dict;get var resolver)))))
-
- (#la;Case inputA branchesA)
+ (^code ((~ [_ (#;Int var)])))
+ (if (variableL;local? var)
+ (let [register (variableL;local-register var)]
+ (if (&&function;nested? outer-arity)
+ (if (n.= +0 register)
+ (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity))
+ (list/map (|>. variableL;local code;int (~) () (`)))))
+ (var$ (&&function;adjust-var outer-arity (variableL;local register))))
+ (var$ (variableL;local register))))
+ (let [register (variableL;captured-register var)]
+ (var$ (let [var (variableL;captured register)]
+ (maybe;default var (dict;get var resolver))))))
+
+ (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)])))
(synthesize-case (recur +0 resolver num-locals) inputA branchesA)
-
- (#la;Function scope bodyA)
+
+ (^multi (^code ("lux function" [(~@ scope)] (~ bodyA)))
+ [(s;run scope (p;some s;int)) (#e;Success raw-env)])
(let [inner-arity (n.inc outer-arity)
- raw-env (&&function;environment scope)
env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env)
env-vars (let [env-size (list;size raw-env)]
- (: (List ls;Variable)
+ (: (List Variable)
(case env-size
+0 (list)
- _ (list/map &&function;to-captured (list;n.range +0 (n.dec env-size))))))
+ _ (list/map variableL;captured (list;n.range +0 (n.dec env-size))))))
resolver' (if (&&function;nested? inner-arity)
(list/fold (function [[from to] resolver']
(dict;put from to resolver'))
@@ -169,27 +174,11 @@
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 (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))])
- (and (n.= _arity (list;size argsS))
- (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)))]
- (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)]
- (~ (&&loop;adjust _env register-offset _bodyS)))))
-
- (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))])
- (call$ funcS' (list/compose argsS' argsS))
-
- _
- (call$ funcS argsS)))
-
- (#la;Procedure name args)
+ (^code ("lux apply" (~@ _)))
+ (synthesize-apply synthesize outer-arity num-locals exprA)
+
+ (^code ((~ [_ (#;Text name)]) (~@ args)))
(procedure$ name (list/map (recur +0 resolver num-locals) args))
- )))
+
+ _
+ exprA)))
diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux
index 91f339bdf..15cb6eca3 100644
--- a/new-luxc/source/luxc/synthesizer/case.lux
+++ b/new-luxc/source/luxc/synthesizer/case.lux
@@ -6,26 +6,12 @@
(coll [list "list/" Fold<List>]))
(meta [code "code/" Eq<Code>]))
(luxc (lang ["la" analysis]
- ["ls" synthesis])
- (synthesizer ["&;" function])))
+ ["ls" synthesis])))
(def: #export (path pattern)
(-> la;Pattern ls;Path)
(case pattern
- (#la;BindP register)
- (` ("lux case bind" (~ (code;nat register))))
-
- (^template [<from> <to>]
- (<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)
+ (^code [(~@ membersP)])
(case (list;reverse membersP)
#;Nil
(' ("lux case pop"))
@@ -45,11 +31,14 @@
(` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))]
prevsP)]
tuple-path))
-
- (#la;VariantP tag num-tags memberP)
+
+ (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ 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)))))))
+ (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))
+
+ _
+ pattern))
(def: #export (weave leftP rightP)
(-> ls;Path ls;Path ls;Path)
diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux
index 4d9970a3f..52aee9a49 100644
--- a/new-luxc/source/luxc/synthesizer/function.lux
+++ b/new-luxc/source/luxc/synthesizer/function.lux
@@ -1,31 +1,8 @@
(;module:
lux
- (lux (data (coll [list "list/" Functor<List>])))
(luxc (lang ["la" analysis]
- ["ls" synthesis])))
-
-(def: #export (environment scope)
- (-> Scope (List ls;Variable))
- (|> scope
- (get@ [#;captured #;mappings])
- (list/map (function [[_ _ ref]]
- (case ref
- (#;Local idx)
- (nat-to-int idx)
-
- (#;Captured idx)
- (|> idx n.inc nat-to-int (i.* -1))
- )))))
-
-(do-template [<name> <comp>]
- [(def: #export (<name> var)
- (-> ls;Variable Bool)
- (<comp> 0 var))]
-
- [self? i.=]
- [local? i.>]
- [captured? i.<]
- )
+ ["ls" synthesis]
+ [";L" variable #+ Variable])))
(do-template [<name> <comp> <ref>]
[(def: #export (<name> arity)
@@ -37,27 +14,15 @@
)
(def: #export (adjust-var outer var)
- (-> ls;Arity ls;Variable ls;Variable)
+ (-> ls;Arity Variable Variable)
(|> outer n.dec nat-to-int (i.+ var)))
-(def: #export (to-captured idx)
- (-> Nat Int)
- (|> idx n.inc nat-to-int (i.* -1)))
-
-(def: #export (captured-idx idx)
- (-> Int Nat)
- (|> idx (i.* -1) int-to-nat n.dec))
-
-(def: #export (to-local idx)
- (-> Nat Int)
- (nat-to-int idx))
-
(def: #export (unfold-apply apply)
(-> la;Analysis [la;Analysis (List la;Analysis)])
(loop [apply apply
args (list)]
(case apply
- (#la;Apply arg func)
+ (^code ("lux apply" (~ arg) (~ func)))
(recur func (#;Cons arg args))
_
diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux
index 8599db981..0070fcd5d 100644
--- a/new-luxc/source/luxc/synthesizer/loop.lux
+++ b/new-luxc/source/luxc/synthesizer/loop.lux
@@ -6,8 +6,8 @@
(coll [list "list/" Functor<List>]))
(meta [code]
[syntax]))
- (luxc (lang ["ls" synthesis])
- (synthesizer ["&&;" function])))
+ (luxc (lang ["ls" synthesis]
+ [";L" variable #+ Variable Register])))
(def: #export (contains-self-reference? exprS)
(-> ls;Synthesis Bool)
@@ -19,7 +19,7 @@
(list;any? contains-self-reference? membersS)
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (&&function;self? var)
+ (variableL;self? var)
(^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))])
(or (contains-self-reference? inputS)
@@ -40,7 +40,7 @@
(list;any? (function [captured]
(case captured
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (&&function;self? var)
+ (variableL;self? var)
_
false))
@@ -109,8 +109,8 @@
)))
(def: #export (adjust env outer-offset exprS)
- (-> (List ls;Variable) ls;Register ls;Synthesis ls;Synthesis)
- (let [resolve-captured (: (-> ls;Variable ls;Variable)
+ (-> (List Variable) Register ls;Synthesis ls;Synthesis)
+ (let [resolve-captured (: (-> Variable Variable)
(function [var]
(let [idx (|> var (i.* -1) int-to-nat n.dec)]
(|> env (list;nth idx) maybe;assume))))]
@@ -161,7 +161,7 @@
(` ((~ (code;text procedure)) (~@ (list/map recur argsS))))
(^ [_ (#;Form (list [_ (#;Int var)]))])
- (if (&&function;captured? var)
+ (if (variableL;captured? var)
(` ((~ (code;int (resolve-captured var)))))
(` ((~ (code;int (|> outer-offset nat-to-int (i.+ var)))))))
diff --git a/new-luxc/source/luxc/synthesizer/structure.lux b/new-luxc/source/luxc/synthesizer/structure.lux
deleted file mode 100644
index 403817c53..000000000
--- a/new-luxc/source/luxc/synthesizer/structure.lux
+++ /dev/null
@@ -1,28 +0,0 @@
-(;module:
- lux
- (luxc (lang ["la" analysis])))
-
-(def: #export (unfold-tuple tuple)
- (-> la;Analysis (List la;Analysis))
- (case tuple
- (#la;Product left right)
- (#;Cons left (unfold-tuple right))
-
- _
- (list tuple)))
-
-(def: #export (unfold-variant variant)
- (-> (Either la;Analysis la;Analysis) [Nat Bool la;Analysis])
- (loop [so-far +0
- variantA variant]
- (case variantA
- (#;Left valueA)
- (case valueA
- (#la;Sum choice)
- (recur (n.inc so-far) choice)
-
- _
- [so-far false valueA])
-
- (#;Right valueA)
- [(n.inc so-far) true valueA])))
diff --git a/new-luxc/source/luxc/synthesizer/variable.lux b/new-luxc/source/luxc/synthesizer/variable.lux
index 01ad101fa..3ce9f2678 100644
--- a/new-luxc/source/luxc/synthesizer/variable.lux
+++ b/new-luxc/source/luxc/synthesizer/variable.lux
@@ -1,22 +1,20 @@
(;module:
lux
- (lux (data [bool "B/" Eq<Bool>]
- [text "T/" Eq<Text>]
- [number]
- (coll [list "L/" Functor<List> Fold<List> Monoid<List>]
+ (lux (data [number]
+ (coll [list "list/" Fold<List> Monoid<List>]
["s" set])))
(luxc (lang ["la" analysis]
- ["ls" synthesis])
- (synthesizer ["&;" function])))
+ ["ls" synthesis]
+ [";L" variable #+ Variable])))
(def: (bound-vars path)
- (-> ls;Path (List ls;Variable))
+ (-> ls;Path (List Variable))
(case path
(#ls;BindP register)
(list (nat-to-int register))
(^or (#ls;SeqP pre post) (#ls;AltP pre post))
- (L/compose (bound-vars pre) (bound-vars post))
+ (list/compose (bound-vars pre) (bound-vars post))
_
(list)))
@@ -31,24 +29,24 @@
(path-bodies post)
(#ls;AltP pre post)
- (L/compose (path-bodies pre) (path-bodies post))
+ (list/compose (path-bodies pre) (path-bodies post))
_
(list)))
(def: (non-arg? arity var)
- (-> ls;Arity ls;Variable Bool)
- (and (&function;local? var)
+ (-> ls;Arity Variable Bool)
+ (and (variableL;local? var)
(n.> arity (int-to-nat var))))
-(type: Tracker (s;Set ls;Variable))
+(type: Tracker (s;Set Variable))
(def: init-tracker Tracker (s;new number;Hash<Int>))
(def: (unused-vars current-arity bound exprS)
- (-> ls;Arity (List ls;Variable) ls;Synthesis (List ls;Variable))
+ (-> ls;Arity (List Variable) ls;Synthesis (List Variable))
(let [tracker (loop [exprS exprS
- tracker (L/fold s;add init-tracker bound)]
+ tracker (list/fold s;add init-tracker bound)]
(case exprS
(#ls;Variable var)
(if (non-arg? current-arity var)
@@ -59,14 +57,14 @@
(recur memberS tracker)
(#ls;Tuple membersS)
- (L/fold recur tracker membersS)
+ (list/fold recur tracker membersS)
(#ls;Call funcS argsS)
- (L/fold recur (recur funcS tracker) argsS)
+ (list/fold recur (recur funcS tracker) argsS)
(^or (#ls;Recur argsS)
(#ls;Procedure name argsS))
- (L/fold recur tracker argsS)
+ (list/fold recur tracker argsS)
(#ls;Let offset inputS outputS)
(|> tracker (recur inputS) (recur outputS))
@@ -75,16 +73,16 @@
(|> tracker (recur testS) (recur thenS) (recur elseS))
(#ls;Loop offset initsS bodyS)
- (recur bodyS (L/fold recur tracker initsS))
+ (recur bodyS (list/fold recur tracker initsS))
(#ls;Case inputS outputPS)
- (let [tracker' (L/fold s;add
- (recur inputS tracker)
- (bound-vars outputPS))]
- (L/fold recur tracker' (path-bodies outputPS)))
+ (let [tracker' (list/fold s;add
+ (recur inputS tracker)
+ (bound-vars outputPS))]
+ (list/fold recur tracker' (path-bodies outputPS)))
(#ls;Function arity env bodyS)
- (L/fold s;remove tracker env)
+ (list/fold s;remove tracker env)
_
tracker