diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/analyser.lux | 51 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/common.lux | 102 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/procedure/host.jvm.lux | 38 |
4 files changed, 110 insertions, 87 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index f0712794d..04d8d58b7 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -8,7 +8,7 @@ [meta] (meta [type] (type ["tc" check])) - [host #+ do-to]) + [host]) (luxc ["&" base] [";L" host] (lang ["la" analysis]) @@ -18,9 +18,7 @@ ["&&;" function] ["&&;" primitive] ["&&;" reference] - ["&&;" type] ["&&;" structure] - ["&&;" case] ["&&;" procedure])) (for {"JVM" (as-is (host;import java.lang.reflect.Method @@ -53,20 +51,7 @@ }) (exception: #export Macro-Expression-Must-Have-Single-Expansion) - -(def: (to-branches raw) - (-> (List Code) (Meta (List [Code Code]))) - (case raw - (^ (list)) - (:: meta;Monad<Meta> wrap (list)) - - (^ (list& patternH bodyH inputT)) - (do meta;Monad<Meta> - [outputT (to-branches inputT)] - (wrap (list& [patternH bodyH] outputT))) - - _ - (&;fail "Uneven expressions for pattern-matching."))) +(exception: #export Unrecognized-Syntax) (def: #export (analyser eval) (-> &;Eval &;Analyser) @@ -105,36 +90,8 @@ (#;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) + (&&procedure;analyse-procedure analyse eval proc-name proc-args) (^template [<tag> <analyser>] (^ (#;Form (list& [_ (<tag> tag)] @@ -180,5 +137,5 @@ (&&function;analyse-apply analyse funcT =func args))) _ - (&;fail (format "Unrecognized syntax: " (%code ast))) + (&;throw Unrecognized-Syntax (%code ast)) ))))))) diff --git a/new-luxc/source/luxc/analyser/procedure.lux b/new-luxc/source/luxc/analyser/procedure.lux index 53ad8276c..225fb7b23 100644 --- a/new-luxc/source/luxc/analyser/procedure.lux +++ b/new-luxc/source/luxc/analyser/procedure.lux @@ -15,9 +15,9 @@ (|> ./common;procedures (dict;merge ./host;procedures))) -(def: #export (analyse-procedure analyse proc-name proc-args) - (-> &;Analyser Text (List Code) (Meta la;Analysis)) +(def: #export (analyse-procedure analyse eval proc-name proc-args) + (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis)) (<| (maybe;default (&;fail (format "Unknown procedure: " (%t proc-name)))) (do maybe;Monad<Maybe> [proc (dict;get proc-name procedures)] - (wrap (proc analyse proc-args))))) + (wrap (proc analyse eval proc-args))))) diff --git a/new-luxc/source/luxc/analyser/procedure/common.lux b/new-luxc/source/luxc/analyser/procedure/common.lux index 6c2e810b5..f64c537cb 100644 --- a/new-luxc/source/luxc/analyser/procedure/common.lux +++ b/new-luxc/source/luxc/analyser/procedure/common.lux @@ -12,11 +12,14 @@ [io]) (luxc ["&" base] (lang ["la" analysis]) - (analyser ["&;" common]))) + (analyser ["&;" common] + [";A" function] + [";A" case] + [";A" type]))) ## [Utils] (type: #export Proc - (-> &;Analyser (List Code) (Meta la;Analysis))) + (-> &;Analyser &;Eval (List Code) (Meta la;Analysis))) (type: #export Bundle (Dict Text Proc)) @@ -42,7 +45,7 @@ (def: (simple proc input-types output-type) (-> Text (List Type) Type Proc) (let [num-expected (list;size input-types)] - (function [analyse args] + (function [analyse eval args] (let [num-actual (list;size args)] (if (n.= num-expected num-actual) (do Monad<Meta> @@ -77,17 +80,17 @@ ## "lux is" represents reference/pointer equality. (def: (lux-is proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] ((binary varT varT Bool proc) - analyse args))))) + analyse eval args))))) ## "lux try" provides a simple way to interact with the host platform's ## error-handling facilities. (def: (lux-try proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -105,11 +108,74 @@ _ (&;fail (wrong-arity proc +1 (list;size args)))))))) +(def: (lux//function proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list [_ (#;Symbol ["" func-name])] + [_ (#;Symbol ["" arg-name])] + body)) + (functionA;analyse-function analyse func-name arg-name body) + + _ + (&;fail (wrong-arity proc +3 (list;size args)))))))) + +(def: (lux//case proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list input [_ (#;Record branches)])) + (caseA;analyse-case analyse input branches) + + _ + (&;fail (wrong-arity proc +2 (list;size args)))))))) + +(do-template [<name> <analyser>] + [(def: (<name> proc) + (-> Text Proc) + (function [analyse eval args] + (&common;with-var + (function [[var-id varT]] + (case args + (^ (list typeC valueC)) + (<analyser> analyse eval typeC valueC) + + _ + (&;fail (wrong-arity proc +2 (list;size args))))))))] + + [lux//check typeA;analyse-check] + [lux//coerce typeA;analyse-coerce]) + +(def: (lux//check//type proc) + (-> Text Proc) + (function [analyse eval args] + (case args + (^ (list 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)) + + _ + (&;fail (wrong-arity proc +1 (list;size args)))))) + (def: lux-procs Bundle (|> (dict;new text;Hash<Text>) (install "is" lux-is) - (install "try" lux-try))) + (install "try" lux-try) + (install "function" lux//function) + (install "case" lux//case) + (install "check" lux//check) + (install "coerce" lux//coerce) + (install "check type" lux//check//type))) (def: io-procs Bundle @@ -222,27 +288,27 @@ (def: (array-get proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] ((binary Nat (type (Array varT)) varT proc) - analyse args))))) + analyse eval args))))) (def: (array-put proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) - analyse args))))) + analyse eval args))))) (def: (array-remove proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] ((binary Nat (type (Array varT)) (type (Array varT)) proc) - analyse args))))) + analyse eval args))))) (def: array-procs Bundle @@ -281,7 +347,7 @@ (def: (atom-new proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -301,19 +367,19 @@ (def: (atom-read proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] ((unary (type (A;Atom varT)) varT proc) - analyse args))))) + analyse eval args))))) (def: (atom-compare-and-swap proc) (-> Text Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] ((trinary varT varT (type (A;Atom varT)) Bool proc) - analyse args))))) + analyse eval args))))) (def: atom-procs Bundle diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux index 84592d4ee..4db7b4dda 100644 --- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux @@ -147,7 +147,7 @@ (def: (array-length proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -167,7 +167,7 @@ (def: (array-new proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list lengthC)) (do meta;Monad<Meta> @@ -261,7 +261,7 @@ (def: (array-read proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -282,7 +282,7 @@ (def: (array-write proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -315,7 +315,7 @@ (def: (object-null proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list)) (do meta;Monad<Meta> @@ -328,7 +328,7 @@ (def: (object-null? proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -347,7 +347,7 @@ (def: (object-synchronized proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -448,7 +448,7 @@ (def: (object-throw proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -472,7 +472,7 @@ (def: (object-class proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list classC)) (case classC @@ -492,7 +492,7 @@ (def: (object-instance? proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (&common;with-var (function [[var-id varT]] (case args @@ -793,7 +793,7 @@ (def: (static-get proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list classC fieldC)) (case [classC fieldC] @@ -811,7 +811,7 @@ (def: (static-put proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list classC fieldC valueC)) (case [classC fieldC] @@ -834,7 +834,7 @@ (def: (virtual-get proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list classC fieldC objectC)) (case [classC fieldC] @@ -853,7 +853,7 @@ (def: (virtual-put proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] @@ -1104,7 +1104,7 @@ (def: (invoke//static proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case (: (e;Error [Text Text (List [Text Code])]) (s;run args ($_ p;seq s;text s;text (p;some (s;tuple (p;seq s;text s;any)))))) (#e;Success [class method argsTC]) @@ -1121,7 +1121,7 @@ (def: (invoke//virtual proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case (: (e;Error [Text Text Code (List [Text Code])]) (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) (#e;Success [class method objectC argsTC]) @@ -1144,7 +1144,7 @@ (def: (invoke//special proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case (: (e;Error [(List Code) [Text Text Code (List [Text Code]) Unit]]) (p;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any))) s;end!))) (#e;Success [_ [class method objectC argsTC _]]) @@ -1163,7 +1163,7 @@ (def: (invoke//interface proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case (: (e;Error [Text Text Code (List [Text Code])]) (s;run args ($_ p;seq s;text s;text s;any (p;some (s;tuple (p;seq s;text s;any)))))) (#e;Success [class-name method objectC argsTC]) @@ -1183,7 +1183,7 @@ (def: (invoke//constructor proc) (-> Text @;Proc) - (function [analyse args] + (function [analyse eval args] (case (: (e;Error [Text (List [Text Code])]) (s;run args ($_ p;seq s;text (p;some (s;tuple (p;seq s;text s;any)))))) (#e;Success [class argsTC]) |