diff options
Diffstat (limited to 'new-luxc/source')
| -rw-r--r-- | new-luxc/source/luxc/base.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/case.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/common.lux | 25 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/function.lux | 5 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/inference.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 18 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/type.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation.lux | 35 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/expression.jvm.lux | 2 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/function.jvm.lux | 67 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/reference.jvm.lux | 22 |
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))] |