aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
authorEduardo Julian2017-11-13 20:02:18 -0400
committerEduardo Julian2017-11-13 20:02:18 -0400
commit2a3946e713821880ecc47580e754315349f2fe73 (patch)
tree7c32a522dff9d09293a5265baa968bc04137c944 /new-luxc/source
parentca297162d5416a8c7b8af5f27757900d82d3ad03 (diff)
- Type-vars no longer get deleted.
- Fixed some bugs.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/base.lux12
-rw-r--r--new-luxc/source/luxc/lang/analysis/case.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/common.lux25
-rw-r--r--new-luxc/source/luxc/lang/analysis/function.lux5
-rw-r--r--new-luxc/source/luxc/lang/analysis/inference.lux12
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux18
-rw-r--r--new-luxc/source/luxc/lang/analysis/type.lux12
-rw-r--r--new-luxc/source/luxc/lang/translation.lux35
-rw-r--r--new-luxc/source/luxc/lang/translation/expression.jvm.lux2
-rw-r--r--new-luxc/source/luxc/lang/translation/function.jvm.lux67
-rw-r--r--new-luxc/source/luxc/lang/translation/reference.jvm.lux22
11 files changed, 110 insertions, 102 deletions
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
index 580f5593f..c7768cd8c 100644
--- a/new-luxc/source/luxc/base.lux
+++ b/new-luxc/source/luxc/base.lux
@@ -63,6 +63,18 @@
(#e;Success [(set@ #;type-context context' compiler)
output]))))
+(def: #export (with-fresh-type-env action)
+ (All [a] (-> (Meta a) (Meta a)))
+ (function [compiler]
+ (let [old (get@ #;type-context compiler)]
+ (case (action (set@ #;type-context tc;fresh-context compiler))
+ (#e;Success [compiler' output])
+ (#e;Success [(set@ #;type-context old compiler')
+ output])
+
+ output
+ output))))
+
(def: #export (infer actualT)
(-> Type (Meta Unit))
(do meta;Monad<Meta>
diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux
index f68733d7f..5f8ed344f 100644
--- a/new-luxc/source/luxc/lang/analysis/case.lux
+++ b/new-luxc/source/luxc/lang/analysis/case.lux
@@ -46,7 +46,7 @@
(#;Var id)
(do meta;Monad<Meta>
[? (&;with-type-env
- (tc;bound? id))]
+ (tc;concrete? id))]
(if ?
(do @
[type' (&;with-type-env
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
index 4cbf5aedf..4d16e4ae6 100644
--- a/new-luxc/source/luxc/lang/analysis/common.lux
+++ b/new-luxc/source/luxc/lang/analysis/common.lux
@@ -1,7 +1,7 @@
(;module:
lux
(lux (control monad
- pipe)
+ ["ex" exception #+ exception:])
(data text/format
[product])
[meta #+ Monad<Meta>]
@@ -14,28 +14,25 @@
(All [a] (-> (Meta Analysis) (Meta [Type Analysis])))
(do Monad<Meta>
[[var-id var-type] (&;with-type-env
- tc;create)
+ tc;var)
analysis (&;with-expected-type var-type
action)
analysis-type (&;with-type-env
- (tc;clean var-id var-type))
- _ (&;with-type-env
- (tc;delete var-id))]
+ (tc;clean var-id var-type))]
(wrap [analysis-type analysis])))
(def: #export (with-var body)
(All [a] (-> (-> [Nat Type] (Meta a)) (Meta a)))
(do Monad<Meta>
[[id var] (&;with-type-env
- tc;create)
- output (body [id var])
- _ (&;with-type-env
- (tc;delete id))]
- (wrap output)))
+ tc;var)]
+ (body [id var])))
+
+(exception: #export Variant-Tag-Out-Of-Bounds)
(def: #export (variant-out-of-bounds-error type size tag)
(All [a] (-> Type Nat Nat (Meta a)))
- (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n"
- " Tag: " (%i (nat-to-int tag)) "\n"
- "Size: " (%i (nat-to-int size)) "\n"
- "Type: " (%type type))))
+ (&;throw Variant-Tag-Out-Of-Bounds
+ (format " Tag: " (%n tag) "\n"
+ "Variant Size: " (%n size) "\n"
+ "Variant Type: " (%type type))))
diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux
index 5a6df4d3e..42a021577 100644
--- a/new-luxc/source/luxc/lang/analysis/function.lux
+++ b/new-luxc/source/luxc/lang/analysis/function.lux
@@ -108,8 +108,5 @@
(format "\n " (%n idx) " " (%code argC))))
(text;join-with "")))))
(do meta;Monad<Meta>
- [expectedT meta;expected-type
- [applyT argsA] (&inference;apply-function analyse funcT args)
- _ (&;with-type-env
- (tc;check expectedT applyT))]
+ [[applyT argsA] (&inference;apply-function analyse funcT args)]
(wrap (la;apply argsA funcA)))))
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux
index fea685024..e2866ac87 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/new-luxc/source/luxc/lang/analysis/inference.lux
@@ -99,7 +99,9 @@
(-> &;Analyser Type (List Code) (Meta [Type (List Analysis)]))
(case args
#;Nil
- (:: Monad<Meta> wrap [inferT (list)])
+ (do Monad<Meta>
+ [_ (&;infer inferT)]
+ (wrap [inferT (list)]))
(#;Cons argC args')
(case inferT
@@ -113,7 +115,7 @@
[[outputT argsA] (apply-function analyse (maybe;assume (type;apply (list varT) inferT)) args)]
(do @
[? (&;with-type-env
- (tc;bound? var-id))
+ (tc;concrete? var-id))
## Quantify over the type if genericity/parametricity
## is discovered.
outputT' (if ?
@@ -145,13 +147,13 @@
## things together more easily.
(#;Function inputT outputT)
(do Monad<Meta>
- [argA (&;with-stacked-errors
+ [[outputT' args'A] (apply-function analyse outputT args')
+ argA (&;with-stacked-errors
(function [_] (Cannot-Infer-Argument
(format "Inferred Type: " (%type inputT) "\n"
" Argument: " (%code argC))))
(&;with-expected-type inputT
- (analyse argC)))
- [outputT' args'A] (apply-function analyse outputT args')]
+ (analyse argC)))]
(wrap [outputT' (list& argA args'A)]))
_
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 5cac1a0d3..9308fcfef 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -64,9 +64,9 @@
(#;Var id)
(do @
- [bound? (&;with-type-env
- (tc;bound? id))]
- (if bound?
+ [concrete? (&;with-type-env
+ (tc;concrete? id))]
+ (if concrete?
(do @
[expectedT' (&;with-type-env
(tc;read id))]
@@ -171,9 +171,9 @@
(#;Var id)
(do @
- [bound? (&;with-type-env
- (tc;bound? id))]
- (if bound?
+ [concrete? (&;with-type-env
+ (tc;concrete? id))]
+ (if concrete?
(do @
[expectedT' (&;with-type-env
(tc;read id))]
@@ -227,8 +227,6 @@
[#let [case-size (list;size group)]
inferenceT (&inference;variant idx case-size variantT)
[inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC))
- _ (&;with-type-env
- (tc;check expectedT inferredT))
temp &scope;next-local]
(wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume))))
@@ -308,9 +306,7 @@
(#;Var _)
(do @
[inferenceT (&inference;record recordT)
- [inferredT membersA] (&inference;apply-function analyse inferenceT membersC)
- _ (&;with-type-env
- (tc;check expectedT inferredT))]
+ [inferredT membersA] (&inference;apply-function analyse inferenceT membersC)]
(wrap (la;product membersA)))
_
diff --git a/new-luxc/source/luxc/lang/analysis/type.lux b/new-luxc/source/luxc/lang/analysis/type.lux
index 74bb712f4..0a8abd76b 100644
--- a/new-luxc/source/luxc/lang/analysis/type.lux
+++ b/new-luxc/source/luxc/lang/analysis/type.lux
@@ -1,8 +1,8 @@
(;module:
lux
(lux (control monad)
- [meta #+ Monad<Meta>]
- (meta (type ["TC" check])))
+ [meta]
+ (meta (type ["tc" check])))
(luxc ["&" base]
(lang ["la" analysis #+ Analysis])))
@@ -11,21 +11,21 @@
## computing Lux type values.
(def: #export (analyse-check analyse eval type value)
(-> &;Analyser &;Eval Code Code (Meta Analysis))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[actualT (eval Type type)
#let [actualT (:! Type actualT)]
expectedT meta;expected-type
_ (&;with-type-env
- (TC;check expectedT actualT))]
+ (tc;check expectedT actualT))]
(&;with-expected-type actualT
(analyse value))))
(def: #export (analyse-coerce analyse eval type value)
(-> &;Analyser &;Eval Code Code (Meta Analysis))
- (do Monad<Meta>
+ (do meta;Monad<Meta>
[actualT (eval Type type)
expectedT meta;expected-type
_ (&;with-type-env
- (TC;check expectedT (:! Type actualT)))]
+ (tc;check expectedT (:! Type actualT)))]
(&;with-expected-type Top
(analyse value))))
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 779cb92fd..c4ebf3642 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -39,24 +39,25 @@
(case code
(^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ metaC)))
(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
+ (&;with-fresh-type-env
+ (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))
(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 [])))
+ [valueA (&;with-expected-type Type
+ (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/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux
index 81cdc1261..fa5f54647 100644
--- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/expression.jvm.lux
@@ -50,7 +50,7 @@
(^ [_ (#;Form (list [_ (#;Int var)]))])
(if (variableL;captured? var)
(referenceT;translate-captured var)
- (referenceT;translate-variable var))
+ (referenceT;translate-local var))
[_ (#;Symbol definition)]
(referenceT;translate-definition definition)
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
index bbf295d18..ea6d371fa 100644
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux
@@ -14,22 +14,14 @@
(lang ["la" analysis]
["ls" synthesis]
(translation [";T" common]
- [";T" runtime])
+ [";T" runtime]
+ [";T" reference])
[";L" variable #+ Variable])))
(def: arity-field Text "arity")
(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-(do-template [<name> <prefix>]
- [(def: #export (<name> idx)
- (-> Nat Text)
- (|> idx nat-to-int %i (format <prefix>)))]
-
- [captured "c"]
- [partial "p"]
- )
-
(def: (poly-arg? arity)
(-> ls;Arity Bool)
(n.> +1 arity))
@@ -97,7 +89,7 @@
(-> (List Variable) $;Def)
(|> (list;enumerate env)
(list/map (function [[env-idx env-source]]
- ($d;field #$;Private $;finalF (captured env-idx) $Object)))
+ ($d;field #$;Private $;finalF (referenceT;captured env-idx) $Object)))
$d;fuse))
(def: (with-partial arity)
@@ -105,28 +97,24 @@
(if (poly-arg? arity)
(|> (list;n.range +0 (n.- +2 arity))
(list/map (function [idx]
- ($d;field #$;Private $;finalF (partial idx) $Object)))
+ ($d;field #$;Private $;finalF (referenceT;partial idx) $Object)))
$d;fuse)
id))
(def: (instance class arity env)
- (-> Text ls;Arity (List Variable) $;Inst)
- (let [captureI (|> env
- (list/map (function [source]
- (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)
- (|> (nullsI (n.dec arity))
- (list ($i;int 0))
- $i;fuse)
- id)]
- (|>. ($i;NEW class)
- $i;DUP
- captureI
- argsI
- ($i;INVOKESPECIAL class "<init>" (init-method env arity) false))))
+ (-> Text ls;Arity (List Variable) (Meta $;Inst))
+ (do meta;Monad<Meta>
+ [captureI+ (monad;map @ referenceT;translate-variable env)
+ #let [argsI (if (poly-arg? arity)
+ (|> (nullsI (n.dec arity))
+ (list ($i;int 0))
+ $i;fuse)
+ id)]]
+ (wrap (|>. ($i;NEW class)
+ $i;DUP
+ ($i;fuse captureI+)
+ argsI
+ ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)))))
(def: (with-reset class arity env)
(-> Text ls;Arity (List Variable) $;Def)
@@ -138,7 +126,7 @@
_ (list;n.range +0 (n.dec env-size)))
(list/map (function [source]
(|>. ($i;ALOAD +0)
- ($i;GETFIELD class (captured source) $Object))))
+ ($i;GETFIELD class (referenceT;captured source) $Object))))
$i;fuse)
argsI (|> (nullsI (n.dec arity))
(list ($i;int 0))
@@ -182,7 +170,7 @@
(list/map (function [register]
(|>. ($i;ALOAD +0)
($i;ALOAD (n.inc register))
- ($i;PUTFIELD class (captured register) $Object))))
+ ($i;PUTFIELD class (referenceT;captured register) $Object))))
$i;fuse)
store-partialI (if (poly-arg? arity)
(|> (list;n.range +0 (n.- +2 arity))
@@ -190,7 +178,7 @@
(let [register (offset-partial idx)]
(|>. ($i;ALOAD +0)
($i;ALOAD (n.inc register))
- ($i;PUTFIELD class (partial idx) $Object)))))
+ ($i;PUTFIELD class (referenceT;partial idx) $Object)))))
$i;fuse)
id)]
($d;method #$;Public $;noneM "<init>" (init-method env arity)
@@ -212,7 +200,7 @@
(list/map (function [[stage @label]]
(let [load-partialsI (if (n.> +0 stage)
(|> (list;n.range +0 (n.dec stage))
- (list/map (|>. partial (load-fieldI class)))
+ (list/map (|>. referenceT;partial (load-fieldI class)))
$i;fuse)
id)]
(cond (i.= arity-over-extent (nat-to-int stage))
@@ -242,7 +230,7 @@
load-capturedI (|> (case env-size
+0 (list)
_ (list;n.range +0 (n.dec env-size)))
- (list/map (|>. captured (load-fieldI class)))
+ (list/map (|>. referenceT;captured (load-fieldI class)))
$i;fuse)]
(|>. ($i;label @label)
($i;NEW class)
@@ -269,7 +257,7 @@
(def: #export (with-function @begin class env arity bodyI)
(-> $;Label Text (List Variable) ls;Arity $;Inst
- [$;Def $;Inst])
+ (Meta [$;Def $;Inst]))
(let [env-size (list;size env)
applyD (: $;Def
(if (poly-arg? arity)
@@ -289,9 +277,10 @@
(with-init class env arity)
(with-reset class arity env)
applyD
- ))
- instanceI (instance class arity env)]
- [functionD instanceI]))
+ ))]
+ (do meta;Monad<Meta>
+ [instanceI (instance class arity env)]
+ (wrap [functionD instanceI]))))
(def: #export (translate-function translate env arity bodyS)
(-> (-> ls;Synthesis (Meta $;Inst))
@@ -302,7 +291,7 @@
[function-class bodyI] (hostL;with-sub-context
(hostL;with-anchor [@begin +1]
(translate bodyS)))
- #let [[functionD instanceI] (with-function @begin function-class env arity bodyI)]
+ [functionD instanceI] (with-function @begin 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 3e835f8e1..8e229af9c 100644
--- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux
@@ -11,8 +11,16 @@
["$i" inst]))
(lang ["ls" synthesis]
[";L" variable #+ Variable]
- (translation [";T" common]
- [";T" function]))))
+ (translation [";T" common]))))
+
+(do-template [<name> <prefix>]
+ [(def: #export (<name> idx)
+ (-> Nat Text)
+ (|> idx nat-to-int %i (format <prefix>)))]
+
+ [captured "c"]
+ [partial "p"]
+ )
(def: #export (translate-captured variable)
(-> Variable (Meta $;Inst))
@@ -20,13 +28,19 @@
[function-class hostL;context]
(wrap (|>. ($i;ALOAD +0)
($i;GETFIELD function-class
- (|> variable i.inc (i.* -1) int-to-nat functionT;captured)
+ (|> variable i.inc (i.* -1) int-to-nat captured)
commonT;$Object)))))
-(def: #export (translate-variable variable)
+(def: #export (translate-local variable)
(-> Variable (Meta $;Inst))
(meta/wrap ($i;ALOAD (int-to-nat variable))))
+(def: #export (translate-variable variable)
+ (-> Variable (Meta $;Inst))
+ (if (variableL;captured? variable)
+ (translate-captured variable)
+ (translate-local variable)))
+
(def: #export (translate-definition [def-module def-name])
(-> Ident (Meta $;Inst))
(let [bytecode-name (format def-module "/" (&;normalize-name def-name))]