diff options
Diffstat (limited to 'new-luxc')
29 files changed, 676 insertions, 462 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index b10f29369..f0712794d 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -1,14 +1,19 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) (data ["e" error] + [product] text/format) [meta] (meta [type] - (type ["tc" check]))) + (type ["tc" check])) + [host #+ do-to]) (luxc ["&" base] + [";L" host] (lang ["la" analysis]) - ["&;" module]) + ["&;" module] + (generator [";G" common])) (. ["&&;" common] ["&&;" function] ["&&;" primitive] @@ -18,6 +23,37 @@ ["&&;" case] ["&&;" procedure])) +(for {"JVM" (as-is (host;import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + (host;import (java.lang.Class c) + (getMethod [String (Array (Class Object))] #try Method)) + (host;import java.lang.Object + (getClass [] (Class Object)) + (toString [] String)) + (def: _object-class (Class Object) (host;class-for Object)) + (def: _apply-args + (Array (Class Object)) + (|> (host;array (Class Object) +2) + (host;array-write +0 _object-class) + (host;array-write +1 _object-class))) + (def: (call-macro macro inputs) + (-> Macro (List Code) (Meta (List Code))) + (do meta;Monad<Meta> + [class (commonG;load-class hostL;function-class)] + (function [compiler] + (do e;Monad<Error> + [apply-method (Class.getMethod ["apply" _apply-args] class) + output (Method.invoke [(:! Object macro) + (|> (host;array Object +2) + (host;array-write +0 (:! Object inputs)) + (host;array-write +1 (:! Object compiler)))] + apply-method)] + (:! (e;Error [Compiler (List Code)]) + output)))))) + }) + +(exception: #export Macro-Expression-Must-Have-Single-Expansion) + (def: (to-branches raw) (-> (List Code) (Meta (List [Code Code]))) (case raw @@ -36,104 +72,113 @@ (-> &;Eval &;Analyser) (: (-> Code (Meta la;Analysis)) (function analyse [ast] - (let [[cursor ast'] ast] - ## The cursor must be set in the compiler for the sake - ## of having useful error messages. - (&;with-cursor cursor - (case ast' - (^template [<tag> <analyser>] - (<tag> value) - (<analyser> value)) - ([#;Bool &&primitive;analyse-bool] - [#;Nat &&primitive;analyse-nat] - [#;Int &&primitive;analyse-int] - [#;Deg &&primitive;analyse-deg] - [#;Frac &&primitive;analyse-frac] - [#;Text &&primitive;analyse-text]) - - (^ (#;Tuple (list))) - &&primitive;analyse-unit - - ## Singleton tuples are equivalent to the element they contain. - (^ (#;Tuple (list singleton))) - (analyse singleton) - - (^ (#;Tuple elems)) - (&&structure;analyse-product analyse elems) - - (^ (#;Record pairs)) - (&&structure;analyse-record analyse pairs) - - (#;Symbol reference) - (&&reference;analyse-reference reference) - - (^ (#;Form (list [_ (#;Text "lux function")] - [_ (#;Symbol ["" func-name])] - [_ (#;Symbol ["" arg-name])] - body))) - (&&function;analyse-function analyse func-name arg-name body) - - (^template [<special> <analyser>] - (^ (#;Form (list [_ (#;Text <special>)] type value))) - (<analyser> analyse eval type value)) - (["lux check" &&type;analyse-check] - ["lux coerce" &&type;analyse-coerce]) - - (^ (#;Form (list& [_ (#;Text "lux case")] - input - branches))) - (do meta;Monad<Meta> - [paired (to-branches branches)] - (&&case;analyse-case analyse input paired)) - - (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) - (&&procedure;analyse-procedure analyse proc-name proc-args) - - (^template [<tag> <analyser>] - (^ (#;Form (list& [_ (<tag> tag)] - values))) - (case values - (#;Cons value #;Nil) - (<analyser> analyse tag value) - - _ - (<analyser> analyse tag (` [(~@ values)])))) - ([#;Nat &&structure;analyse-sum] - [#;Tag &&structure;analyse-tagged-sum]) - - (#;Tag tag) - (&&structure;analyse-tagged-sum analyse tag (' [])) - - (^ (#;Form (list& func args))) - (do meta;Monad<Meta> - [[funcT =func] (&&common;with-unknown-type - (analyse func))] - (case =func - (#la;Definition def-name) - (do @ - [[def-type def-anns def-value] (meta;find-def def-name)] - (if (meta;macro? def-anns) - (do @ - [## macro-expansion (function [compiler] - ## (case (macro-caller def-value args compiler) - ## (#e;Success [compiler' output]) - ## (#e;Success [compiler' output]) - - ## (#e;Error error) - ## ((&;fail error) compiler))) - macro-expansion (: (Meta (List Code)) - (undefined))] - (case macro-expansion - (^ (list single-expansion)) - (analyse single-expansion) - - _ - (&;fail (format "Macro expressions must expand to a single expression: " (%code ast))))) - (&&function;analyse-apply analyse funcT =func args))) - - _ - (&&function;analyse-apply analyse funcT =func args))) - - _ - (&;fail (format "Unrecognized syntax: " (%code ast))) - )))))) + (do meta;Monad<Meta> + [expectedT meta;expected-type] + (let [[cursor ast'] ast] + ## The cursor must be set in the compiler for the sake + ## of having useful error messages. + (&;with-cursor cursor + (case ast' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#;Bool &&primitive;analyse-bool] + [#;Nat &&primitive;analyse-nat] + [#;Int &&primitive;analyse-int] + [#;Deg &&primitive;analyse-deg] + [#;Frac &&primitive;analyse-frac] + [#;Text &&primitive;analyse-text]) + + (^ (#;Tuple (list))) + &&primitive;analyse-unit + + ## Singleton tuples are equivalent to the element they contain. + (^ (#;Tuple (list singleton))) + (analyse singleton) + + (^ (#;Tuple elems)) + (&&structure;analyse-product analyse elems) + + (^ (#;Record pairs)) + (&&structure;analyse-record analyse pairs) + + (#;Symbol reference) + (&&reference;analyse-reference reference) + + (^ (#;Form (list [_ (#;Text "lux function")] + [_ (#;Symbol ["" func-name])] + [_ (#;Symbol ["" arg-name])] + body))) + (&&function;analyse-function analyse func-name arg-name body) + + (^template [<special> <analyser>] + (^ (#;Form (list [_ (#;Text <special>)] type value))) + (<analyser> analyse eval type value)) + (["lux check" &&type;analyse-check] + ["lux coerce" &&type;analyse-coerce]) + + (^ (#;Form (list [_ (#;Text "lux check type")] valueC))) + (do meta;Monad<Meta> + [valueA (&;with-expected-type Type + (analyse valueC)) + expected meta;expected-type + _ (&;with-type-env + (tc;check expected Type))] + (wrap valueA)) + + (^ (#;Form (list& [_ (#;Text "lux case")] + input + branches))) + (do meta;Monad<Meta> + [paired (to-branches branches)] + (&&case;analyse-case analyse input paired)) + + (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) + (&&procedure;analyse-procedure analyse proc-name proc-args) + + (^template [<tag> <analyser>] + (^ (#;Form (list& [_ (<tag> tag)] + values))) + (case values + (#;Cons value #;Nil) + (<analyser> analyse tag value) + + _ + (<analyser> analyse tag (` [(~@ values)])))) + ([#;Nat &&structure;analyse-sum] + [#;Tag &&structure;analyse-tagged-sum]) + + (#;Tag tag) + (&&structure;analyse-tagged-sum analyse tag (' [])) + + (^ (#;Form (list& func args))) + (do meta;Monad<Meta> + [[funcT =func] (&&common;with-unknown-type + (analyse func))] + (case =func + (#la;Definition def-name) + (do @ + [[def-type def-anns def-value] (meta;find-def def-name)] + (if (meta;macro? def-anns) + (do @ + [expansion (function [compiler] + (case (call-macro (:! Macro def-value) args compiler) + (#e;Success [compiler' output]) + (#e;Success [compiler' output]) + + (#e;Error error) + ((&;fail error) compiler)))] + (case expansion + (^ (list single)) + (analyse single) + + _ + (&;throw Macro-Expression-Must-Have-Single-Expansion (%code ast)))) + (&&function;analyse-apply analyse funcT =func args))) + + _ + (&&function;analyse-apply analyse funcT =func args))) + + _ + (&;fail (format "Unrecognized syntax: " (%code ast))) + ))))))) diff --git a/new-luxc/source/luxc/analyser/case.lux b/new-luxc/source/luxc/analyser/case.lux index b65b9ff94..b17dbcbfd 100644 --- a/new-luxc/source/luxc/analyser/case.lux +++ b/new-luxc/source/luxc/analyser/case.lux @@ -1,6 +1,7 @@ (;module: lux (lux (control [monad #+ do] + ["ex" exception #+ exception:] eq) (data [bool] [number] @@ -21,10 +22,15 @@ ["&;" structure]) (. ["&&;" coverage])) +(exception: #export Cannot-Match-Type-With-Pattern) +(exception: #export Sum-Type-Has-No-Case) +(exception: #export Unrecognized-Pattern-Syntax) + (def: (pattern-error type pattern) (-> Type Code Text) - (format "Cannot match this type: " (%type type) "\n" - " With this pattern: " (%code pattern))) + (Cannot-Match-Type-With-Pattern + (format " Type: " (%type type) "\n" + "Pattern: " (%code pattern)))) ## Type-checking on the input value is done during the analysis of a ## "case" expression, to ensure that the patterns being used make @@ -56,6 +62,14 @@ tc;existential)] (simplify-case-type (maybe;assume (type;apply (list exT) type)))) + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (:: meta;Monad<Meta> wrap outputT) + + #;None + (&;fail (format "Cannot apply type " (%type funcT) " to type " (%type inputT)))) + _ (:: meta;Monad<Meta> wrap type))) @@ -122,7 +136,7 @@ [inputT' (simplify-case-type inputT)] (case inputT' (#;Product _) - (let [sub-types (type;flatten-tuple inputT) + (let [sub-types (type;flatten-tuple inputT') num-sub-types (maybe;default (list;size sub-types) num-tags) num-sub-patterns (list;size sub-patterns) @@ -175,7 +189,7 @@ [inputT' (simplify-case-type inputT)] (case inputT' (#;Sum _) - (let [flat-sum (type;flatten-variant inputT) + (let [flat-sum (type;flatten-variant inputT') size-sum (list;size flat-sum) num-cases (maybe;default size-sum num-tags)] (case (list;nth idx flat-sum) @@ -196,7 +210,9 @@ nextA]))) _ - (&;fail (format "Cannot match index " (%n idx) " against type: " (%type inputT))))) + (&;throw Sum-Type-Has-No-Case + (format "Case: " (%n idx) "\n" + "Type: " (%type inputT))))) _ (&;fail (pattern-error inputT pattern))))) @@ -211,10 +227,10 @@ (analyse-pattern (#;Some (list;size group)) inputT (` ((~ (code;nat idx)) (~@ values))) next))) _ - (&;fail (format "Unrecognized pattern syntax: " (%code pattern))) + (&;throw Unrecognized-Pattern-Syntax (%code pattern)) )) -(def: #export (analyse-case analyse input branches) +(def: #export (analyse-case analyse inputC branches) (-> &;Analyser Code (List [Code Code]) (Meta la;Analysis)) (case branches #;Nil @@ -223,7 +239,7 @@ (#;Cons [patternH bodyH] branchesT) (do meta;Monad<Meta> [[inputT inputA] (&common;with-unknown-type - (analyse input)) + (analyse inputC)) outputH (analyse-pattern #;None inputT patternH (analyse bodyH)) outputT (monad;map @ (function [[patternT bodyT]] diff --git a/new-luxc/source/luxc/analyser/function.lux b/new-luxc/source/luxc/analyser/function.lux index 1432308f8..55896480e 100644 --- a/new-luxc/source/luxc/analyser/function.lux +++ b/new-luxc/source/luxc/analyser/function.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control monad) + (lux (control monad + ["ex" exception #+ exception:]) (data [maybe] [text] text/format @@ -14,6 +15,9 @@ (analyser ["&;" common] ["&;" inference]))) +(exception: #export Invalid-Function-Type) +(exception: #export Cannot-Apply-Function) + ## [Analysers] (def: #export (analyse-function analyse func-name arg-name body) (-> &;Analyser Text Text Code (Meta Analysis)) @@ -21,7 +25,7 @@ [functionT meta;expected-type] (loop [expectedT functionT] (&;with-stacked-errors - (function [_] (format "Functions require function types: " (type;to-text expectedT))) + (function [_] (Invalid-Function-Type (%type expectedT))) (case expectedT (#;Named name unnamedT) (recur unnamedT) @@ -92,8 +96,9 @@ (def: #export (analyse-apply analyse funcT funcA args) (-> &;Analyser Type Analysis (List Code) (Meta Analysis)) (&;with-stacked-errors - (function [_] (format "Cannot apply function " (%type funcT) - " to args: " (|> args (list/map %code) (text;join-with " ")))) + (function [_] + (Cannot-Apply-Function (format " Function: " (%type funcT) "\n" + "Arguments: " (|> args (list/map %code) (text;join-with " "))))) (do Monad<Meta> [expected meta;expected-type [applyT argsA] (&inference;apply-function analyse funcT args) diff --git a/new-luxc/source/luxc/analyser/inference.lux b/new-luxc/source/luxc/analyser/inference.lux index 86832ae9e..049abec28 100644 --- a/new-luxc/source/luxc/analyser/inference.lux +++ b/new-luxc/source/luxc/analyser/inference.lux @@ -1,9 +1,11 @@ (;module: lux - (lux (control monad) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) (data [maybe] + [text] text/format - (coll [list "L/" Functor<List>])) + (coll [list "list/" Functor<List>])) [meta #+ Monad<Meta>] (meta [type] (type ["tc" check]))) @@ -11,6 +13,10 @@ (lang ["la" analysis #+ Analysis]) (analyser ["&;" common]))) +(exception: #export Cannot-Infer) +(exception: #export Cannot-Infer-Argument) +(exception: #export Smaller-Variant-Than-Expected) + ## When doing inference, type-variables often need to be created in ## order to figure out which types are present in the expression being ## inferred. @@ -23,7 +29,7 @@ (-> Nat Nat Type Type) (case type (#;Primitive name params) - (#;Primitive name (L/map (replace-var var-id bound-idx) params)) + (#;Primitive name (list/map (replace-var var-id bound-idx) params)) (^template [<tag>] (<tag> left right) @@ -41,15 +47,41 @@ (^template [<tag>] (<tag> env quantified) - (<tag> (L/map (replace-var var-id bound-idx) env) + (<tag> (list/map (replace-var var-id bound-idx) env) (replace-var var-id (n.+ +2 bound-idx) quantified))) ([#;UnivQ] [#;ExQ]) - (#;Named name unnamedT) - (#;Named name - (replace-var var-id bound-idx unnamedT)) + _ + type)) +(def: (replace-bound bound-idx replacementT type) + (-> Nat Type Type Type) + (case type + (#;Primitive name params) + (#;Primitive name (list/map (replace-bound bound-idx replacementT) params)) + + (^template [<tag>] + (<tag> left right) + (<tag> (replace-bound bound-idx replacementT left) + (replace-bound bound-idx replacementT right))) + ([#;Sum] + [#;Product] + [#;Function] + [#;Apply]) + + (#;Bound idx) + (if (n.= bound-idx idx) + replacementT + type) + + (^template [<tag>] + (<tag> env quantified) + (<tag> (list/map (replace-bound bound-idx replacementT) env) + (replace-bound (n.+ +2 bound-idx) replacementT quantified))) + ([#;UnivQ] + [#;ExQ]) + _ type)) @@ -66,7 +98,7 @@ #;Nil (:: Monad<Meta> wrap [funcT (list)]) - (#;Cons arg args') + (#;Cons argC args') (case funcT (#;Named name unnamedT) (apply-function analyse unnamedT args) @@ -104,29 +136,31 @@ (do Monad<Meta> [[outputT' args'A] (apply-function analyse outputT args') argA (&;with-stacked-errors - (function [_] (format "Expected type: " (%type inputT) "\n" - " For argument: " (%code arg))) + (function [_] (Cannot-Infer-Argument + (format "Inferred Type: " (%type inputT) "\n" + " Argument: " (%code argC)))) (&;with-expected-type inputT - (analyse arg)))] + (analyse argC)))] (wrap [outputT' (list& argA args'A)])) _ - (&;fail (format "Cannot apply a non-function: " (%type funcT)))) + (&;throw Cannot-Infer (format "Inference Type: " (%type funcT) + " Arguments: " (|> args (list/map %code) (text;join-with " "))))) )) ## Turns a record type into the kind of function type suitable for inference. -(def: #export (record-inference-type type) +(def: #export (record type) (-> Type (Meta Type)) (case type (#;Named name unnamedT) (do Monad<Meta> - [unnamedT+ (record-inference-type unnamedT)] - (wrap (#;Named name unnamedT+))) + [unnamedT+ (record unnamedT)] + (wrap unnamedT+)) (^template [<tag>] (<tag> env bodyT) (do Monad<Meta> - [bodyT+ (record-inference-type bodyT)] + [bodyT+ (record bodyT)] (wrap (<tag> env bodyT+)))) ([#;UnivQ] [#;ExQ]) @@ -138,47 +172,57 @@ (&;fail (format "Not a record type: " (%type type))))) ## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant-inference-type tag expected-size type) +(def: #export (variant tag expected-size type) (-> Nat Nat Type (Meta Type)) - (case type - (#;Named name unnamedT) - (do Monad<Meta> - [unnamedT+ (variant-inference-type tag expected-size unnamedT)] - (wrap (#;Named name unnamedT+))) - - (^template [<tag>] - (<tag> env bodyT) + (loop [depth +0 + currentT type] + (case currentT + (#;Named name unnamedT) (do Monad<Meta> - [bodyT+ (variant-inference-type tag expected-size bodyT)] - (wrap (<tag> env bodyT+)))) - ([#;UnivQ] - [#;ExQ]) - - (#;Sum _) - (let [cases (type;flatten-variant type) - actual-size (list;size cases) - boundary (n.dec expected-size)] - (cond (or (n.= expected-size actual-size) - (and (n.> expected-size actual-size) - (n.< boundary tag))) - (case (list;nth tag cases) - (#;Some caseT) - (:: Monad<Meta> wrap (type;function (list caseT) type)) - - #;None - (&common;variant-out-of-bounds-error type expected-size tag)) - - (n.< expected-size actual-size) - (&;fail (format "Variant type is smaller than expected." "\n" - "Expected: " (%i (nat-to-int expected-size)) "\n" - " Actual: " (%i (nat-to-int actual-size)))) - - (n.= boundary tag) - (let [caseT (type;variant (list;drop boundary cases))] - (:: Monad<Meta> wrap (type;function (list caseT) type))) - - ## else - (&common;variant-out-of-bounds-error type expected-size tag))) + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [<tag>] + (<tag> env bodyT) + (do Monad<Meta> + [bodyT+ (recur (n.inc depth) bodyT)] + (wrap (<tag> env bodyT+)))) + ([#;UnivQ] + [#;ExQ]) + + (#;Sum _) + (let [cases (type;flatten-variant currentT) + actual-size (list;size cases) + boundary (n.dec expected-size)] + (cond (or (n.= expected-size actual-size) + (and (n.> expected-size actual-size) + (n.< boundary tag))) + (case (list;nth tag cases) + (#;Some caseT) + (:: Monad<Meta> wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT))))) + + #;None + (&common;variant-out-of-bounds-error type expected-size tag)) + + (n.< expected-size actual-size) + (&;throw Smaller-Variant-Than-Expected + (format "Expected: " (%i (nat-to-int expected-size)) "\n" + " Actual: " (%i (nat-to-int actual-size)))) + + (n.= boundary tag) + (let [caseT (type;variant (list;drop boundary cases))] + (:: Monad<Meta> wrap (if (n.= +0 depth) + (type;function (list caseT) currentT) + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (type;function (list (replace! caseT)) + (replace! currentT)))))) + + ## else + (&common;variant-out-of-bounds-error type expected-size tag))) - _ - (&;fail (format "Not a variant type: " (%type type))))) + _ + (&;fail (format "Not a variant type: " (%type type)))))) diff --git a/new-luxc/source/luxc/analyser/reference.lux b/new-luxc/source/luxc/analyser/reference.lux index 9756a1b9c..4a2f6dbc5 100644 --- a/new-luxc/source/luxc/analyser/reference.lux +++ b/new-luxc/source/luxc/analyser/reference.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]) ["&;" scope])) @@ -10,23 +10,23 @@ ## [Analysers] (def: (analyse-definition def-name) (-> Ident (Meta Analysis)) - (do Monad<Meta> - [actual (meta;find-def-type def-name) - expected meta;expected-type + (do meta;Monad<Meta> + [actualT (meta;find-def-type def-name) + expectedT meta;expected-type _ (&;with-type-env - (TC;check expected actual))] + (tc;check expectedT actualT))] (wrap (#la;Definition def-name)))) (def: (analyse-variable var-name) (-> Text (Meta (Maybe Analysis))) - (do Monad<Meta> + (do meta;Monad<Meta> [?var (&scope;find var-name)] (case ?var - (#;Some [actual ref]) + (#;Some [actualT ref]) (do @ - [expected meta;expected-type + [expectedT meta;expected-type _ (&;with-type-env - (TC;check expected actual))] + (tc;check expectedT actualT))] (wrap (#;Some (#la;Variable ref)))) #;None @@ -36,7 +36,7 @@ (-> Ident (Meta Analysis)) (case reference ["" simple-name] - (do Monad<Meta> + (do meta;Monad<Meta> [?var (analyse-variable simple-name)] (case ?var (#;Some analysis) diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 8c1f7118c..7720202d8 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -1,6 +1,7 @@ (;module: lux (lux (control [monad #+ do] + ["ex" exception #+ exception:] pipe) [function] (concurrency ["A" atom]) @@ -23,13 +24,13 @@ (analyser ["&;" common] ["&;" inference]))) +(exception: #export Not-Variant-Type) +(exception: #export Not-Tuple-Type) +(exception: #export Cannot-Infer-Numeric-Tag) + (type: Type-Error (-> Type Text)) -(def: (not-variant type) - Type-Error - (format "Invalid type for variant: " (%type type))) - (def: (not-quantified type) Type-Error (format "Not a quantified type: " (%type type))) @@ -37,12 +38,14 @@ (def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Meta la;Analysis)) (do meta;Monad<Meta> - [expected meta;expected-type] + [expectedT meta;expected-type] (&;with-stacked-errors - (function [_] (not-variant expected)) - (case expected + (function [_] (Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT)))) + (case expectedT (#;Sum _) - (let [flat (type;flatten-variant expected) + (let [flat (type;flatten-variant expectedT) type-size (list;size flat)] (case (list;nth tag flat) (#;Some variant-type) @@ -53,7 +56,7 @@ (wrap (la;sum tag type-size temp valueA))) #;None - (&common;variant-out-of-bounds-error expected type-size tag))) + (&common;variant-out-of-bounds-error expectedT type-size tag))) (#;Named name unnamedT) (&;with-expected-type unnamedT @@ -65,26 +68,28 @@ (tc;bound? id))] (if bound? (do @ - [expected' (&;with-type-env - (tc;read id))] - (&;with-expected-type expected' + [expectedT' (&;with-type-env + (tc;read id))] + (&;with-expected-type expectedT' (analyse-sum analyse tag valueC))) ## Cannot do inference when the tag is numeric. ## This is because there is no way of knowing how many ## cases the inferred sum type would have. - (&;fail (not-variant expected)))) + (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT))))) (#;UnivQ _) (do @ [[var-id var] (&;with-type-env tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) (analyse-sum analyse tag valueC))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) (analyse-sum analyse tag valueC)))) (#;Apply inputT funT) @@ -97,15 +102,17 @@ (analyse-sum analyse tag valueC))) _ - (&;fail ""))))) + (&;throw Not-Variant-Type (format " Tag: " (%n tag) "\n" + "Value: " (%code valueC) "\n" + " Type: " (%type expectedT))))))) (def: (analyse-typed-product analyse members) (-> &;Analyser (List Code) (Meta la;Analysis)) (do meta;Monad<Meta> - [expected meta;expected-type] - (loop [expected expected + [expectedT meta;expected-type] + (loop [expectedT expectedT members members] - (case [expected members] + (case [expectedT members] ## If the type and the code are still ongoing, match each ## sub-expression to its corresponding type. [(#;Product leftT rightT) (#;Cons leftC rightC)] @@ -150,10 +157,11 @@ (def: #export (analyse-product analyse membersC) (-> &;Analyser (List Code) (Meta la;Analysis)) (do meta;Monad<Meta> - [expected meta;expected-type] + [expectedT meta;expected-type] (&;with-stacked-errors - (function [_] (format "Invalid type for tuple: " (%type expected))) - (case expected + (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)]))))) + (case expectedT (#;Product _) (analyse-typed-product analyse membersC) @@ -167,16 +175,16 @@ (tc;bound? id))] (if bound? (do @ - [expected' (&;with-type-env - (tc;read id))] - (&;with-expected-type expected' + [expectedT' (&;with-type-env + (tc;read id))] + (&;with-expected-type expectedT' (analyse-product analyse membersC))) ## Must do inference... (do @ [membersTA (monad;map @ (|>. analyse &common;with-unknown-type) membersC) _ (&;with-type-env - (tc;check expected + (tc;check expectedT (type;tuple (list/map product;left membersTA))))] (wrap (la;product (list/map product;right membersTA)))))) @@ -184,13 +192,13 @@ (do @ [[var-id var] (&;with-type-env tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) (analyse-product analyse membersC))) (#;ExQ _) (&common;with-var (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expected)) + (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) (analyse-product analyse membersC)))) (#;Apply inputT funT) @@ -203,7 +211,8 @@ (analyse-product analyse membersC))) _ - (&;fail "") + (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Value: " (%code (` [(~@ membersC)])))) )))) (def: #export (analyse-tagged-sum analyse tag valueC) @@ -216,7 +225,7 @@ (#;Var _) (do @ [#let [case-size (list;size group)] - inferenceT (&inference;variant-inference-type idx case-size variantT) + inferenceT (&inference;variant idx case-size variantT) [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) _ (&;with-type-env (tc;check expectedT inferredT)) @@ -295,7 +304,7 @@ [members (normalize members) [members recordT] (order members) expectedT meta;expected-type - inferenceT (&inference;record-inference-type recordT) + inferenceT (&inference;record recordT) [inferredT membersA] (&inference;apply-function analyse inferenceT members) _ (&;with-type-env (tc;check expectedT inferredT))] diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index bac16fd79..580f5593f 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -27,8 +27,8 @@ #let [location (format file "," (|> line nat-to-int %i) "," (|> col nat-to-int %i))]] - (meta;fail (format "@ " location - "\n" message)))) + (meta;fail (format message "\n\n" + "@ " location)))) (def: #export (assert message test) (-> Text Bool (Meta Unit)) @@ -57,7 +57,7 @@ (function [compiler] (case (action (get@ #;type-context compiler)) (#e;Error error) - (#e;Error error) + ((fail error) compiler) (#e;Success [context' output]) (#e;Success [(set@ #;type-context context' compiler) @@ -136,7 +136,7 @@ (#e;Error error) (#e;Error (if (text/= "" error) (handler []) - (format error "\n-----------------------------------------\n" (handler []))))))) + (format (handler []) "\n\n-----------------------------------------\n\n" error)))))) (def: fresh-bindings (All [k v] (Bindings k v)) diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux index 4ac937402..ad5f578e3 100644 --- a/new-luxc/source/luxc/generator.lux +++ b/new-luxc/source/luxc/generator.lux @@ -11,10 +11,10 @@ [io] (world [file #+ File])) (luxc ["&" base] + [";L" host] ["&;" io] ["&;" module] ["&;" parser] - ["&;" host] ["&;" analyser] ["&;" analyser/common] ["&;" synthesizer] @@ -75,24 +75,12 @@ [result action] (exhaust action))) -(def: (ensure-new-module! file-hash module-name) - (-> Nat Text (Meta Unit)) - (do meta;Monad<Meta> - [module-exists? (meta;module-exists? module-name) - _ (: (Meta Unit) - (if module-exists? - (&;fail (format "Cannot re-define a module: " module-name)) - (wrap []))) - _ (&module;create file-hash module-name)] - (wrap []))) - (def: prelude Text "lux") (def: (with-active-compilation [module-name file-name source-code] action) (All [a] (-> [Text Text Text] (Meta a) (Meta a))) (do meta;Monad<Meta> - [_ (ensure-new-module! (text/hash source-code) module-name) - #let [init-cursor [file-name +0 +0]] + [#let [init-cursor [file-name +1 +0]] output (&;with-source-code [init-cursor +0 source-code] action) _ (&module;flag-compiled! module-name)] @@ -113,17 +101,21 @@ (-> (List File) Text File Compiler (T;Task Compiler)) (do T;Monad<Task> [_ (&io;prepare-module target-dir module-name) - [file-name file-content] (&io;read-module source-dirs module-name)] + [file-name file-content] (&io;read-module source-dirs module-name) + #let [module-hash (text/hash file-content)]] (case (meta;run' compiler (do meta;Monad<Meta> - [[artifacts _] (&&common;with-artifacts - (with-active-compilation [module-name - file-name - file-content] - (exhaust - (do @ - [code parse] - (generate code)))))] + [[_ artifacts _] (&module;with-module module-hash module-name + (&&common;with-artifacts + (with-active-compilation [module-name + file-name + file-content] + (exhaust + (do @ + [code parse + #let [[cursor _] code]] + (&;with-cursor cursor + (generate code)))))))] (wrap artifacts) ## (&module;generate-descriptor module-name) )) @@ -139,7 +131,7 @@ (#e;Error error) (T;fail error)))) -(def: init-cursor Cursor ["" +0 +0]) +(def: init-cursor Cursor ["" +1 +0]) (def: #export init-type-context Type-Context @@ -170,15 +162,15 @@ (def: #export (generate-program program target sources) (-> Text File (List File) (T;Task Unit)) (do T;Monad<Task> - [compiler (|> (case (&&runtime;generate (init-compiler (io;run &host;init-host))) + [compiler (|> (case (&&runtime;generate (init-compiler (io;run hostL;init-host))) (#e;Error error) (T;fail error) (#e;Success [compiler [runtime-bc function-bc]]) (do @ [_ (&io;prepare-target target) - _ (&io;write-file target &&runtime;runtime-class runtime-bc) - _ (&io;write-file target &&runtime;function-class function-bc)] + _ (&io;write-file target hostL;runtime-class runtime-bc) + _ (&io;write-file target hostL;function-class function-bc)] (wrap compiler))) (: (T;Task Compiler)) (:: @ map (generate-module sources prelude target)) (:: @ join) diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux index 53912f5d0..f20c83f6e 100644 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -2,9 +2,9 @@ lux (lux (control [monad #+ do]) [meta "meta/" Monad<Meta>]) - (luxc (lang ["ls" synthesis]) - (generator [expr] - (host ["$" jvm] + (luxc [";L" host] + (lang ["ls" synthesis]) + (generator (host ["$" jvm] (jvm ["$t" type] ["$i" inst])))) [../runtime]) @@ -24,7 +24,7 @@ (def: peekI $;Inst (|>. $i;DUP - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class "pm_peek" ($t;method (list ../runtime;$Stack) (#;Some $Object) @@ -33,7 +33,7 @@ (def: popI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-class + (|>. ($i;INVOKESTATIC hostL;runtime-class "pm_pop" ($t;method (list ../runtime;$Stack) (#;Some ../runtime;$Stack) @@ -42,19 +42,20 @@ (def: pushI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-class + (|>. ($i;INVOKESTATIC hostL;runtime-class "pm_push" ($t;method (list ../runtime;$Stack $Object) (#;Some ../runtime;$Stack) (list)) false))) -(def: (generate-pattern' stack-depth @else @end path) - (-> Nat $;Label $;Label ls;Path (Meta $;Inst)) +(def: (generate-pattern' generate stack-depth @else @end path) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat $;Label $;Label ls;Path (Meta $;Inst)) (case path (#ls;ExecP bodyS) (do meta;Monad<Meta> - [bodyI (expr;generate bodyS)] + [bodyI (generate bodyS)] (wrap (|>. (pop-altI stack-depth) bodyI ($i;GOTO @end)))) @@ -104,7 +105,7 @@ (#ls;TupleP idx subP) (do meta;Monad<Meta> - [subI (generate-pattern' stack-depth @else @end subP) + [subI (generate-pattern' generate stack-depth @else @end subP) #let [[idx tail?] (case idx (#;Left idx) [idx false] @@ -124,7 +125,7 @@ (|>. peekI ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class (if tail? "pm_right" "pm_left") ($t;method (list ../runtime;$Tuple $t;int) (#;Some $Object) @@ -135,7 +136,7 @@ (#ls;VariantP idx subP) (do meta;Monad<Meta> - [subI (generate-pattern' stack-depth @else @end subP) + [subI (generate-pattern' generate stack-depth @else @end subP) #let [[idx last?] (case idx (#;Left idx) [idx false] @@ -151,7 +152,7 @@ ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) ($i;int (nat-to-int idx)) flagI - ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant" + ($i;INVOKESTATIC hostL;runtime-class "pm_variant" ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) (#;Some ../runtime;$Datum) (list)) @@ -168,16 +169,16 @@ (#ls;SeqP leftP rightP) (do meta;Monad<Meta> - [leftI (generate-pattern' stack-depth @else @end leftP) - rightI (generate-pattern' stack-depth @else @end rightP)] + [leftI (generate-pattern' generate stack-depth @else @end leftP) + rightI (generate-pattern' generate stack-depth @else @end rightP)] (wrap (|>. leftI rightI))) (#ls;AltP leftP rightP) (do meta;Monad<Meta> [@alt-else $i;make-label - leftI (generate-pattern' (n.inc stack-depth) @alt-else @end leftP) - rightI (generate-pattern' stack-depth @else @end rightP)] + leftI (generate-pattern' generate (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-pattern' generate stack-depth @else @end rightP)] (wrap (|>. $i;DUP leftI ($i;label @alt-else) @@ -185,30 +186,42 @@ rightI))) )) -(def: (generate-pattern path @end) - (-> ls;Path $;Label (Meta $;Inst)) +(def: (generate-pattern generate path @end) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Path $;Label (Meta $;Inst)) (do meta;Monad<Meta> [@else $i;make-label - pathI (generate-pattern' +1 @else @end path)] + pathI (generate-pattern' generate +1 @else @end path)] (wrap (|>. pathI ($i;label @else) $i;POP - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class "pm_fail" ($t;method (list) #;None (list)) false) $i;NULL ($i;GOTO @end))))) -(def: #export (generate valueS path) - (-> ls;Synthesis ls;Path (Meta $;Inst)) +(def: #export (generate-case generate valueS path) + (-> (-> ls;Synthesis (Meta $;Inst)) + ls;Synthesis ls;Path (Meta $;Inst)) (do meta;Monad<Meta> [@end $i;make-label - valueI (expr;generate valueS) - pathI (generate-pattern path @end)] + valueI (generate valueS) + pathI (generate-pattern generate path @end)] (wrap (|>. valueI $i;NULL $i;SWAP pushI pathI ($i;label @end))))) + +(def: #export (generate-let generate register inputS exprS) + (-> (-> ls;Synthesis (Meta $;Inst)) + Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) + (do meta;Monad<Meta> + [inputI (generate inputS) + exprI (generate exprS)] + (wrap (|>. inputI + ($i;ASTORE register) + exprI)))) diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 116c29fb5..685bf2335 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control monad) + (lux (control monad + ["ex" exception #+ exception:]) (data text/format) [meta #+ Monad<Meta> "Meta/" Monad<Meta>]) (luxc ["&" base] @@ -15,8 +16,11 @@ ["&;" procedure] ["&;" function] ["&;" reference] + [";G" case] (host ["$" jvm])))) +(exception: #export Unrecognized-Synthesis) + (def: #export (generate synthesis) (-> ls;Synthesis (Meta $;Inst)) (case synthesis @@ -47,6 +51,12 @@ (#ls;Definition definition) (&reference;generate-definition definition) + (#ls;Let register inputS exprS) + (caseG;generate-let generate register inputS exprS) + + (#ls;Case inputS pathPS) + (caseG;generate-case generate inputS pathPS) + (#ls;Function arity env body) (&function;generate-function generate env arity body) @@ -57,25 +67,5 @@ (&procedure;generate-procedure generate name args) _ - (meta;fail "Unrecognized synthesis.") + (&;throw Unrecognized-Synthesis "") )) - -## (def: #export (eval type code) -## (-> Type Code (Meta Top)) -## (do Monad<Meta> -## [analysis (&;with-expected-type leftT -## (&analyser;analyser eval code)) -## #let [synthesis (&synthesizer;synthesize analysis)] -## inst (generate synthesis)] -## (&eval;eval inst))) - -## (def: analyse -## &;Analyser -## (&analyser;analyser eval)) - -## (def: #export (generate input) -## (-> Code (Meta Unit)) -## (do Monad<Meta> -## [analysis (analyse input) -## #let [synthesis (&synthesizer;synthesize analysis)]] -## (generate-synthesis synthesis))) diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux index 97d3a7c91..ce92b9010 100644 --- a/new-luxc/source/luxc/generator/function.jvm.lux +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -5,6 +5,7 @@ (coll [list "list/" Functor<List> Monoid<List>])) [meta]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -58,7 +59,7 @@ (def: get-amount-of-partialsI $;Inst (|>. ($i;ALOAD +0) - ($i;GETFIELD &runtime;function-class &runtime;partials-field $t;int))) + ($i;GETFIELD hostL;function-class &runtime;partials-field $t;int))) (def: (load-fieldI class field) (-> Text Text $;Inst) @@ -77,9 +78,9 @@ later-applysI (if (n.> &runtime;num-apply-variants amount) (applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount)) id)] - (|>. ($i;CHECKCAST &runtime;function-class) + (|>. ($i;CHECKCAST hostL;function-class) (inputsI start max-args) - ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature max-args) false) + ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature max-args) false) later-applysI))) (def: (inc-intI by) @@ -167,9 +168,9 @@ (-> ls;Arity Nat $;Inst) (if (n.= +1 arity) (|>. ($i;int 0) - ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)) + ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false)) (|>. ($i;ILOAD (n.inc env-size)) - ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)))) + ($i;INVOKESPECIAL hostL;function-class "<init>" function-init-method false)))) (def: (with-init class env arity) (-> Text (List ls;Variable) ls;Arity $;Def) @@ -262,7 +263,7 @@ ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) @default @labels) casesI - ($i;INVOKESTATIC &runtime;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) + ($i;INVOKESTATIC hostL;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) $i;NULL $i;ARETURN )))) @@ -306,7 +307,7 @@ _ (&common;store-class function-class ($d;class #$;V1.6 #$;Public $;finalC function-class (list) - ($;simple-class &runtime;function-class) (list) + ($;simple-class hostL;function-class) (list) functionD))] (wrap instanceI))) @@ -326,9 +327,9 @@ argsI (monad;map @ generate argsS) #let [applyI (|> (segment &runtime;num-apply-variants argsI) (list/map (function [chunkI+] - (|>. ($i;CHECKCAST &runtime;function-class) + (|>. ($i;CHECKCAST hostL;function-class) ($i;fuse chunkI+) - ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) + ($i;INVOKEVIRTUAL hostL;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) $i;fuse)]] (wrap (|>. functionI applyI)))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index f515e86ac..37ab75020 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -22,68 +22,72 @@ (L/map (function [code] (` ((~' #static) (~ (code;local-symbol code)) (~' int))))) wrap)) -(with-expansions [<conversion> (declare D2F D2I D2L - F2D F2I F2L - I2B I2C I2D I2F I2L I2S - L2D L2F L2I) - <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE - T_BYTE T_SHORT T_INT T_LONG) - <class> (declare CHECKCAST NEW INSTANCEOF) - <member> (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD - INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE) - <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2 - POP POP2 - SWAP) - <jump> (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL - IFEQ IFNE IFLT IFLE IFGT IFGE - GOTO) - <var> (declare ILOAD LLOAD DLOAD ALOAD - ISTORE LSTORE ASTORE) - <arithmetic> (declare IADD ISUB IMUL IDIV IREM - LADD LSUB LMUL LDIV LREM LCMP - FADD FSUB FMUL FDIV FREM FCMPG FCMPL - DADD DSUB DMUL DDIV DREM DCMPG DCMPL) - <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR - LAND LOR LXOR LSHL LSHR LUSHR) - <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY - AALOAD AASTORE - BALOAD BASTORE - SALOAD SASTORE - IALOAD IASTORE - LALOAD LASTORE - FALOAD FASTORE - DALOAD DASTORE - CALOAD CASTORE) - <concurrency> (declare MONITORENTER MONITOREXIT) - <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)] - (host;import org.objectweb.asm.Opcodes - (#static NOP int) - - <conversion> - <primitive> - - <class> - - <stack> - <jump> - - (#static ACONST_NULL int) - - <var> - - <arithmetic> - <bit-wise> - - <array> - - <member> - - (#static ATHROW int) - - <concurrency> - - <return> - )) +(`` (host;import org.objectweb.asm.Opcodes + (#static NOP int) + + ## Conversion + (~~ (declare D2F D2I D2L + F2D F2I F2L + I2B I2C I2D I2F I2L I2S + L2D L2F L2I)) + + ## Primitive + (~~ (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE + T_BYTE T_SHORT T_INT T_LONG)) + + ## Class + (~~ (declare CHECKCAST NEW INSTANCEOF)) + + ## Stack + (~~ (declare DUP DUP_X1 DUP_X2 + DUP2 DUP2_X1 DUP2_X2 + POP POP2 + SWAP)) + + ## Jump + (~~ (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL + IFEQ IFNE IFLT IFLE IFGT IFGE + GOTO)) + + (#static ACONST_NULL int) + + ## Var + (~~ (declare ILOAD LLOAD DLOAD ALOAD + ISTORE LSTORE ASTORE)) + + ## Arithmetic + (~~ (declare IADD ISUB IMUL IDIV IREM + LADD LSUB LMUL LDIV LREM LCMP + FADD FSUB FMUL FDIV FREM FCMPG FCMPL + DADD DSUB DMUL DDIV DREM DCMPG DCMPL)) + + ## Bit-wise + (~~ (declare IAND IOR IXOR ISHL ISHR IUSHR + LAND LOR LXOR LSHL LSHR LUSHR)) + + ## Array + (~~ (declare ARRAYLENGTH NEWARRAY ANEWARRAY + AALOAD AASTORE + BALOAD BASTORE + SALOAD SASTORE + IALOAD IASTORE + LALOAD LASTORE + FALOAD FASTORE + DALOAD DASTORE + CALOAD CASTORE)) + + ## Member + (~~ (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD + INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)) + + (#static ATHROW int) + + ## Concurrency + (~~ (declare MONITORENTER MONITOREXIT)) + + ## Return + (~~ (declare RETURN IRETURN LRETURN DRETURN ARETURN)) + )) (host;import org.objectweb.asm.FieldVisitor (visitEnd [] void)) @@ -152,7 +156,9 @@ [NOP] ## Stack - [DUP] [DUP2] [DUP2_X1] [DUP2_X2] [POP] [POP2] [SWAP] + [DUP] [DUP_X1] [DUP_X2] [DUP2] [DUP2_X1] [DUP2_X2] + [POP] [POP2] + [SWAP] ## Conversions [D2F] [D2I] [D2L] diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux index fc6ffae1f..571ba4835 100644 --- a/new-luxc/source/luxc/generator/primitive.jvm.lux +++ b/new-luxc/source/luxc/generator/primitive.jvm.lux @@ -2,8 +2,9 @@ lux (lux (control monad) (data text/format) - [meta #+ Monad<Meta> "Meta/" Monad<Meta>]) + [meta "meta/" Monad<Meta>]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -16,18 +17,18 @@ (def: #export generate-unit (Meta $;Inst) - (Meta/wrap ($i;string ../runtime;unit))) + (meta/wrap ($i;string hostL;unit))) (def: #export (generate-bool value) (-> Bool (Meta $;Inst)) - (Meta/wrap ($i;GETSTATIC "java.lang.Boolean" + (meta/wrap ($i;GETSTATIC "java.lang.Boolean" (if value "TRUE" "FALSE") ($t;class "java.lang.Boolean" (list))))) (do-template [<name> <type> <load> <wrap>] [(def: #export (<name> value) (-> <type> (Meta $;Inst)) - (Meta/wrap (|>. (<load> value) <wrap>)))] + (meta/wrap (|>. (<load> value) <wrap>)))] [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] [generate-int Int $i;long ($i;wrap #$;Long)] diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index 48a820663..fd76082a6 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -10,6 +10,7 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -56,7 +57,7 @@ (def: $Object-Array $;Type ($t;array +1 $Object)) (def: $String $;Type ($t;class "java.lang.String" (list))) (def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list))) -(def: $Function $;Type ($t;class &runtime;function-class (list))) +(def: $Function $;Type ($t;class hostL;function-class (list))) (def: #export (install name unnamed) (-> Text (-> Text Proc) @@ -142,8 +143,8 @@ (def: (lux//try riskyI) Unary (|>. riskyI - ($i;CHECKCAST &runtime;function-class) - ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false))) + ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "try" try-method false))) ## [[Bits]] (do-template [<name> <op>] @@ -263,9 +264,9 @@ [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-class "div_nat" nat-method false)] + ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-class "rem_nat" nat-method false)] + ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] @@ -276,9 +277,9 @@ [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-class "mul_deg" deg-method false)] + ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-class "div_deg" deg-method false)] + ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] @@ -296,10 +297,10 @@ [<eq> 0] [<lt> -1])] - [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)] + [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP] [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG] - [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)] + [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)] ) (do-template [<name> <prepare> <transform>] @@ -317,15 +318,15 @@ [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] [frac//to-deg ($i;unwrap #$;Double) - (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "frac_to_deg" + (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list)) false))] [frac//encode ($i;unwrap #$;Double) ($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)] [frac//decode ($i;CHECKCAST "java.lang.String") - ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] + ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] [deg//to-frac ($i;unwrap #$;Long) - (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac" + (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) false))] ) @@ -365,7 +366,7 @@ ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false) ($i;wrap #$;Boolean)] [text//char ($i;CHECKCAST "java.lang.String") jvm-intI - ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) + ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) lux-intI] ) @@ -378,7 +379,7 @@ <op>))] [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i;INVOKESTATIC &runtime;runtime-class "text_clip" + ($i;INVOKESTATIC hostL;runtime-class "text_clip" ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] @@ -466,7 +467,7 @@ messageI ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false) - ($i;string &runtime;unit))) + ($i;string hostL;unit))) (def: (io//error messageI) Unary @@ -515,20 +516,20 @@ ## [[Processes]] (def: (process//concurrency-level []) Nullary - (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int) + (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int) lux-intI)) (def: (process//future procedureI) Unary - (|>. procedureI ($i;CHECKCAST &runtime;function-class) - ($i;INVOKESTATIC &runtime;runtime-class "future" + (|>. procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "future" ($t;method (list $Function) (#;Some $Object) (list)) false))) (def: (process//schedule [millisecondsI procedureI]) Binary (|>. millisecondsI ($i;unwrap #$;Long) - procedureI ($i;CHECKCAST &runtime;function-class) - ($i;INVOKESTATIC &runtime;runtime-class "schedule" + procedureI ($i;CHECKCAST hostL;function-class) + ($i;INVOKESTATIC hostL;runtime-class "schedule" ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) ## [Bundles] diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux index f908c6c6e..fc6bdd01b 100644 --- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux @@ -15,6 +15,7 @@ ["s" syntax #+ syntax:]) [host]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -494,13 +495,13 @@ (wrap (|>. valueI ($i;unwrap primitive) ($i;PUTSTATIC class field (#$;Primitive primitive)) - ($i;string &runtime;unit)))) + ($i;string hostL;unit)))) #;None (wrap (|>. valueI ($i;CHECKCAST class) ($i;PUTSTATIC class field ($t;class class (list))) - ($i;string &runtime;unit))))) + ($i;string hostL;unit))))) _ (&;fail (format "Wrong syntax for '" proc "'.")))) @@ -655,7 +656,7 @@ (case returnT #;None (|>. returnI - ($i;string &runtime;unit)) + ($i;string hostL;unit)) (#;Some type) (case type diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index d2ad42a2c..d3f99ae6a 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -7,6 +7,7 @@ [meta] [host]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -40,20 +41,16 @@ (visitEnd [] void) (toByteArray [] (Array byte))) -(def: #export runtime-class Text "LuxRuntime") -(def: #export function-class Text "LuxFunction") -(def: #export unit Text "\u0000") - (def: $Object $;Type ($t;class "java.lang.Object" (list))) (def: $Object-Array $;Type ($t;array +1 $Object)) (def: $String $;Type ($t;class "java.lang.String" (list))) (def: #export $Stack $;Type ($t;array +1 $Object)) -(def: #export $Tuple $;Type ($t;array +1 $Object)) -(def: #export $Variant $;Type ($t;array +1 $Object)) +(def: #export $Tuple $;Type $Object-Array) +(def: #export $Variant $;Type $Object-Array) (def: #export $Tag $;Type $t;int) (def: #export $Flag $;Type $Object) (def: #export $Datum $;Type $Object) -(def: #export $Function $;Type ($t;class function-class (list))) +(def: #export $Function $;Type ($t;class hostL;function-class (list))) (def: $Throwable $;Type ($t;class "java.lang.Throwable" (list))) (def: #export logI @@ -69,7 +66,7 @@ (def: variantI $;Inst - ($i;INVOKESTATIC runtime-class "variant_make" variant-method false)) + ($i;INVOKESTATIC hostL;runtime-class "variant_make" variant-method false)) (def: #export leftI $;Inst @@ -93,9 +90,13 @@ $;Inst (|>. ($i;int 0) $i;NULL - ($i;string unit) + ($i;string hostL;unit) variantI)) +(def: #export string-concatI + $;Inst + ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)) + (def: #export partials-field Text "partials") (def: #export apply-method Text "apply") (def: #export num-apply-variants Nat +8) @@ -108,8 +109,59 @@ $;Def (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) - store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)] - (|>. ($d;method #$;Public $;staticM "variant_make" + store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE) + force-textMT ($t;method (list $Object) (#;Some $String) (list))] + (|>. ($d;method #$;Public $;staticM "force_text" force-textMT + (<| $i;with-label (function [@is-null]) + $i;with-label (function [@normal-object]) + $i;with-label (function [@array-loop]) + $i;with-label (function [@within-bounds]) + $i;with-label (function [@is-first]) + $i;with-label (function [@elem-end]) + $i;with-label (function [@fold-end]) + (let [on-normal-objectI (|>. ($i;ALOAD +0) + ($i;INVOKEVIRTUAL "java.lang.Object" "toString" ($t;method (list) (#;Some $String) (list)) false)) + on-null-objectI ($i;string "NULL") + arrayI (|>. ($i;ALOAD +0) + ($i;CHECKCAST ($t;descriptor $Object-Array))) + recurseI ($i;INVOKESTATIC hostL;runtime-class "force_text" force-textMT false) + force-elemI (|>. $i;DUP arrayI $i;SWAP $i;AALOAD recurseI) + swap2 (|>. $i;DUP2_X2 ## X,Y => Y,X,Y + $i;POP2 ## Y,X,Y => Y,X + ) + add-spacingI (|>. ($i;string ", ") $i;SWAP string-concatI) + merge-with-totalI (|>. $i;DUP_X2 $i;POP ## TSIP => TPSI + swap2 ## TPSI => SITP + string-concatI ## SITP => SIT + $i;DUP_X2 $i;POP ## SIT => TSI + ) + foldI (|>. $i;DUP ## TSI => TSII + ($i;IFEQ @is-first) ## TSI + force-elemI add-spacingI merge-with-totalI ($i;GOTO @elem-end) + ($i;label @is-first) ## TSI + force-elemI merge-with-totalI + ($i;label @elem-end) ## TSI + ) + inc-idxI (|>. ($i;int 1) $i;IADD) + on-array-objectI (|>. ($i;string "[") ## T + arrayI $i;ARRAYLENGTH ## TS + ($i;int 0) ## TSI + ($i;label @array-loop) ## TSI + $i;DUP2 + ($i;IF_ICMPGT @within-bounds) ## TSI + $i;POP2 ($i;string "]") string-concatI ($i;GOTO @fold-end) + ($i;label @within-bounds) + foldI inc-idxI ($i;GOTO @array-loop) + ($i;label @fold-end))]) + (|>. ($i;ALOAD +0) + ($i;IFNULL @is-null) + ($i;ALOAD +0) + ($i;INSTANCEOF ($t;descriptor $Object-Array)) + ($i;IFEQ @normal-object) + on-array-objectI $i;ARETURN + ($i;label @normal-object) on-normal-objectI $i;ARETURN + ($i;label @is-null) on-null-objectI $i;ARETURN))) + ($d;method #$;Public $;staticM "variant_make" ($t;method (list $t;int $Object $Object) (#;Some $Variant) (list)) @@ -120,14 +172,18 @@ store-valueI $i;ARETURN))))) +(def: #export force-textI + $;Inst + ($i;INVOKESTATIC hostL;runtime-class "force_text" ($t;method (list $Object) (#;Some $String) (list)) false)) + (def: nat-methods $;Def (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) - less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) $BigInteger ($t;class "java.math.BigInteger" (list)) upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list)) div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) - upcastI ($i;INVOKESTATIC runtime-class "_toUnsignedBigInteger" upcast-method false) + upcastI ($i;INVOKESTATIC hostL;runtime-class "_toUnsignedBigInteger" upcast-method false) downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method @@ -300,7 +356,7 @@ (let [subjectI ($i;LLOAD +0) paramI ($i;LLOAD +2) equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) - count-leading-zerosI ($i;INVOKESTATIC runtime-class "count_leading_zeros" clz-method false) + count-leading-zerosI ($i;INVOKESTATIC hostL;runtime-class "count_leading_zeros" clz-method false) calc-max-shiftI (|>. subjectI count-leading-zerosI paramI count-leading-zerosI ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false) @@ -373,7 +429,7 @@ ($i;int 1) $i;AALOAD $i;ARETURN)) - ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Stack $t;int $Object) (#;Some $Object) (list)) + ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Variant $Tag $Flag) (#;Some $Object) (list)) (<| $i;with-label (function [@begin]) $i;with-label (function [@just-return]) $i;with-label (function [@then]) @@ -487,7 +543,7 @@ ($i;label @from) ($i;ALOAD +0) $i;NULL - ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) rightI $i;ARETURN ($i;label @to) @@ -505,14 +561,14 @@ (Meta &common;Bytecode) (do meta;Monad<Meta> [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list) + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC hostL;runtime-class (list) ["java.lang.Object" (list)] (list) (|>. adt-methods nat-methods frac-methods deg-methods pm-methods io-methods))] - _ (&common;store-class runtime-class bytecode)] + _ (&common;store-class hostL;runtime-class bytecode)] (wrap bytecode))) (def: generate-function @@ -526,24 +582,24 @@ (list/map $i;ALOAD) $i;fuse)] (|>. preI - ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false) - ($i;CHECKCAST function-class) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature (n.dec arity)) false) + ($i;CHECKCAST hostL;function-class) ($i;ALOAD arity) - ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + ($i;INVOKEVIRTUAL hostL;function-class apply-method (apply-signature +1) false) $i;ARETURN))))) (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1))) $d;fuse) - bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list) + bytecode ($d;abstract #$;V1.6 #$;Public $;noneC hostL;function-class (list) ["java.lang.Object" (list)] (list) (|>. ($d;field #$;Public $;finalF partials-field $t;int) ($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list)) (|>. ($i;ALOAD +0) ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false) ($i;ALOAD +0) ($i;ILOAD +1) - ($i;PUTFIELD function-class partials-field $t;int) + ($i;PUTFIELD hostL;function-class partials-field $t;int) $i;RETURN)) applyI))] - _ (&common;store-class function-class bytecode)] + _ (&common;store-class hostL;function-class bytecode)] (wrap bytecode))) (def: #export generate diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index cee5800cd..28196b914 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -3,9 +3,10 @@ (lux (control [monad #+ do]) (data text/format (coll [list])) - [meta #+ Monad<Meta> "Meta/" Monad<Meta>] + [meta] [host #+ do-to]) (luxc ["&" base] + [";L" host] (lang ["la" analysis] ["ls" synthesis]) ["&;" analyser] @@ -21,7 +22,7 @@ (def: #export (generate-tuple generate members) (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) - (do Monad<Meta> + (do meta;Monad<Meta> [#let [size (list;size members)] _ (&;assert "Cannot generate tuples with less than 2 elements." (n.>= +2 size)) @@ -47,12 +48,12 @@ (def: #export (generate-variant generate tag tail? member) (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) - (do Monad<Meta> + (do meta;Monad<Meta> [memberI (generate member)] (wrap (|>. ($i;int (nat-to-int tag)) (flagI tail?) memberI - ($i;INVOKESTATIC ../runtime;runtime-class + ($i;INVOKESTATIC hostL;runtime-class "variant_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index f118deed2..b74c9748c 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -95,3 +95,7 @@ (get@ #;host) (:! &&common;Host) (get@ #&&common;loader))]))) + +(def: #export runtime-class Text "LuxRuntime") +(def: #export function-class Text "LuxFunction") +(def: #export unit Text "\u0000") diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux index 299616e6b..2ed106545 100644 --- a/new-luxc/source/luxc/module/descriptor/annotation.lux +++ b/new-luxc/source/luxc/module/descriptor/annotation.lux @@ -11,7 +11,7 @@ ["&" ../common] [luxc ["&;" parser]]) -(def: dummy-cursor Cursor ["" +0 +0]) +(def: dummy-cursor Cursor ["" +1 +0]) (do-template [<name> <code>] [(def: <name> &;Signal <code>)] diff --git a/new-luxc/source/luxc/scope.lux b/new-luxc/source/luxc/scope.lux index bd9a3233f..4ce8a51cb 100644 --- a/new-luxc/source/luxc/scope.lux +++ b/new-luxc/source/luxc/scope.lux @@ -60,14 +60,14 @@ (let [[ref-type init-ref] (maybe;default (undefined) (get-ref name top-outer)) [ref inner'] (list/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)]) - (function [scope [ref inner]] + (function [scope ref+inner] [(#;Captured (get@ [#;captured #;counter] scope)) (#;Cons (update@ #;captured (: (-> Captured Captured) (|>. (update@ #;counter n.inc) - (update@ #;mappings (&;pl-put name [ref-type ref])))) + (update@ #;mappings (&;pl-put name [ref-type (product;left ref+inner)])))) scope) - inner)])) + (product;right ref+inner))])) [init-ref #;Nil] (list;reverse inner)) scopes (list/compose inner' outer)] diff --git a/new-luxc/source/luxc/synthesizer/case.lux b/new-luxc/source/luxc/synthesizer/case.lux index 8221b4f8d..02b1bfba5 100644 --- a/new-luxc/source/luxc/synthesizer/case.lux +++ b/new-luxc/source/luxc/synthesizer/case.lux @@ -49,17 +49,17 @@ (#ls;VariantP (if last? (#;Right tag) (#;Left tag)) (path memberP))))) -(def: #export (weave nextP prevP) +(def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) - (with-expansions [<default> (as-is (#ls;AltP prevP nextP))] - (case [nextP prevP] + (with-expansions [<default> (as-is (#ls;AltP leftP rightP))] + (case [leftP rightP] [#ls;UnitP #ls;UnitP] #ls;UnitP (^template [<tag> <test>] - [(<tag> next) (<tag> prev)] - (if (<test> next prev) - prevP + [(<tag> left) (<tag> right)] + (if (<test> left right) + leftP <default>)) ([#ls;BindP n.=] [#ls;BoolP B/=] @@ -70,22 +70,22 @@ [#ls;TextP T/=]) (^template [<tag> <side>] - [(<tag> (<side> next-idx) next-then) (<tag> (<side> prev-idx) prev-then)] - (if (n.= next-idx prev-idx) - (weave next-then prev-then) + [(<tag> (<side> left-idx) left-then) (<tag> (<side> right-idx) right-then)] + (if (n.= left-idx right-idx) + (weave left-then right-then) <default>)) ([#ls;TupleP #;Left] [#ls;TupleP #;Right] [#ls;VariantP #;Left] [#ls;VariantP #;Right]) - [(#ls;SeqP next-pre next-post) (#ls;SeqP prev-pre prev-post)] - (case (weave next-pre prev-pre) + [(#ls;SeqP left-pre left-post) (#ls;SeqP right-pre right-post)] + (case (weave left-pre right-pre) (#ls;AltP _ _) <default> weavedP - (#ls;SeqP weavedP (weave next-post prev-post))) + (#ls;SeqP weavedP (weave left-post right-post))) _ <default>))) diff --git a/new-luxc/source/luxc/synthesizer/function.lux b/new-luxc/source/luxc/synthesizer/function.lux index e8b2a7ec4..4d9970a3f 100644 --- a/new-luxc/source/luxc/synthesizer/function.lux +++ b/new-luxc/source/luxc/synthesizer/function.lux @@ -1,6 +1,6 @@ (;module: lux - (lux (data (coll [list "L/" Functor<List> Fold<List>]))) + (lux (data (coll [list "list/" Functor<List>]))) (luxc (lang ["la" analysis] ["ls" synthesis]))) @@ -8,14 +8,14 @@ (-> Scope (List ls;Variable)) (|> scope (get@ [#;captured #;mappings]) - (L/map (function [[_ _ ref]] - (case ref - (#;Local idx) - (nat-to-int idx) - - (#;Captured idx) - (|> idx n.inc nat-to-int (i.* -1)) - ))))) + (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) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 3e94c7521..e660b4158 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -4,7 +4,8 @@ ["p" parser]) (concurrency ["P" promise] ["T" task]) - (data ["e" error]) + (data ["e" error] + text/format) [io #- run] [cli #+ program: CLI]) (luxc ["&;" generator])) @@ -45,9 +46,10 @@ [?output action] (case ?output (#e;Error error) - (error! error) + (exec (log! (format "\n" + "Compilation failed:" "\n" + error "\n")) + (_lux_proc ["io" "exit"] [1])) (#e;Success output) (wrap output)))) - - diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux index 34846a988..f9e165c03 100644 --- a/new-luxc/test/test/luxc/generator/case.lux +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -12,6 +12,7 @@ [analyser] [synthesizer] (generator ["@" case] + [";G" expr] ["@;" eval] ["@;" runtime] ["@;" common])) @@ -72,9 +73,10 @@ (test "Can generate pattern-matching." (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate valueS - (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) - (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))] + sampleI (@;generate-case exprG;generate + valueS + (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) + (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false)))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) @@ -85,8 +87,9 @@ (test "Can bind values." (|> (do meta;Monad<Meta> [runtime-bytecode @runtime;generate - sampleI (@;generate (#ls;Nat to-bind) - (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))] + sampleI (@;generate-case exprG;generate + (#ls;Nat to-bind) + (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1))))] (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux index 2e909dd7e..66eacca27 100644 --- a/new-luxc/test/test/luxc/generator/primitive.lux +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -10,7 +10,8 @@ ["r" math/random] [meta] test) - (luxc (lang ["ls" synthesis]) + (luxc [";L" host] + (lang ["ls" synthesis]) [analyser] [synthesizer] (generator ["@" expr] @@ -54,7 +55,7 @@ (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success valueG) - (is @runtime;unit (:! Text valueG)) + (is hostL;unit (:! Text valueG)) _ false))) diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux index 097c2b802..7a047dff9 100644 --- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux +++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux @@ -15,7 +15,8 @@ [meta #+ Monad<Meta>] [host] test) - (luxc (lang ["ls" synthesis]) + (luxc [";L" host] + (lang ["ls" synthesis]) [analyser] [synthesizer] (generator ["@" expr] @@ -520,7 +521,7 @@ (@eval;eval sampleI)) (meta;run (init-compiler [])) (case> (#e;Success outputG) - (is @runtime;unit (:! Text outputG)) + (is hostL;unit (:! Text outputG)) (#e;Error error) false))) diff --git a/new-luxc/test/test/luxc/generator/reference.lux b/new-luxc/test/test/luxc/generator/reference.lux index 0fa32acb3..32f9c1b80 100644 --- a/new-luxc/test/test/luxc/generator/reference.lux +++ b/new-luxc/test/test/luxc/generator/reference.lux @@ -12,6 +12,7 @@ (generator [";G" statement] [";G" eval] [";G" expr] + [";G" case] [";G" runtime] (host ["$" jvm] (jvm ["$i" inst])))) @@ -54,3 +55,24 @@ (#e;Error error) false))) )))) + +(context: "Variables." + (<| (times +100) + (do @ + [register (|> r;nat (:: @ map (n.% +100))) + value r;int] + ($_ seq + (test "Can refer to local variables/registers." + (|> (do meta;Monad<Meta> + [sampleI (caseG;generate-let exprG;generate + register + (#ls;Int value) + (#ls;Variable (nat-to-int register)))] + (evalG;eval sampleI)) + (meta;run (init-compiler [])) + (case> (#e;Success outputG) + (i.= value (:! Int outputG)) + + (#e;Error error) + false))) + )))) diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux index 927ff9ec8..7a14788b7 100644 --- a/new-luxc/test/test/luxc/generator/structure.lux +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -14,7 +14,8 @@ [meta #+ Monad<Meta>] [host] test) - (luxc (lang ["ls" synthesis]) + (luxc [";L" host] + (lang ["ls" synthesis]) [analyser] [synthesizer] (generator ["@" expr] @@ -39,7 +40,7 @@ (-> [ls;Synthesis Top] Bool) (case prediction #ls;Unit - (is @runtime;unit (:! Text sample)) + (is hostL;unit (:! Text sample)) (^template [<tag> <type> <test>] (<tag> prediction') diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index cde7c3714..13eb44402 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -27,8 +27,7 @@ ["_;G" reference] (procedure ["_;G" common] ["_;G" host])) - )) - ) + ))) (program: args (test;run)) |